COMMENT ⊗   VALID 00028 PAGES VERSION 17-1(7)
RECORD PAGE   DESCRIPTION
 00001 00001
 00004 00002	HISTORY
 00014 00003	Leap Generators.
 00019 00004	NOW FOR THE DEFINITIONS OF ALL THE RUNTIME ROUTINES.
 00025 00005	ZERODATA (LEAP VARIABLES)
 00030 00006	DSCR LEPINI
 00034 00007	DSCR LEAPC1, LEAPC2
 00036 00008	DSCR STSET
 00040 00009	
 00044 00010	STCHK:	PUSH	P,D			SAVE NUMBER OF PARAMS TO CHECK.
 00054 00011	DSCR CHKSAT -
 00055 00012	FOREACH STATEMENT HANDLERS.
 00068 00013	↑DERIV:					DERIVED SETS.
 00071 00014	DATUM HANDLERS
 00077 00015	DSCR - PPSTO,EPPSTO,GETPROP  execs for PROPS
 00080 00016	 MAKE AND ERASE
 00082 00017	 VARIOUS BOOLEANS.
 00087 00018	DSCR DELT, SIPGO, STPRIM, ECVI, STLOP, PUTIN, LPPHI, etc.
 00095 00019	DSCR PUTINL,HLDPNT,REMXD,REPLCX LISTGT
 00099 00020	DSCR CVLS,LSSUB,SELIP,SELSBL 
 00104 00021	GETTING NEW ITEMS.
 00111 00022	 CASE, EXPRESSION CONDITIONALS.
 00113 00023	 STORE ROUTINES.
 00118 00024	
 00122 00025	DSCR CALMP -MATCHING PROCEDURE EXECS
 00127 00026	DSCR REMEMBER EXECS RMASET,RMBSET,RMSTK
 00132 00027	 EXECS FOR DYNAMIC BINDING OF PROC ITEMS
 00135 00028	EXECS FOR APPLY
 00137 ENDMK
⊗;
COMMENT ⊗HISTORY
AUTHOR,REASON
021  102100000007  ⊗;


COMMENT ⊗
VERSION 17-1(7) 8-30-73 BY JRL MOD GETITM SLIGHTLY TO MAKE MORE EFFICIENT
VERSION 17-1(6) 8-30-73 BY JRL BUG #NX# HANDLE DATUM(BINDIV,DATUM) CORRECTLY
VERSION 17-1(5) 8-16-73 BY JRL REMOVE REFERENCES TO LEAPSW
VERSION 17-1(4) 8-13-73 BY JRL SAV SEMBLKS FOR BINDIT,ANY,MAINPI,EVTYPE
VERSION 17-1(3) 8-13-73 BY JRL BUG #NR# DRYROT REMOP STCNST IN NEW OF STC
VERSION 17-1(2) 8-5-73 BY JRL BUG #NM# RELATIONS INVOLVING BINDING ITEMVARS
VERSION 17-1(1) 7-26-73 BY RHT JUST CHECKING ON JRL
VERSION 17-1(0) 7-26-73 BY JRL **** VERSION 17 ****
VERSION 16-2(87) 7-14-73 BY RHT ADD EXECS FOR SPROUT APPLY
VERSION 16-2(86) 6-15-73 BY JRL BUG #MR# STRING ARRAY IS NOT A STRING
VERSION 16-2(85) 5-7-73 BY JRL ADD CONELM EXEC
VERSION 16-2(84) 4-2-73 BY JRL MAKE BNDTRP KNOW ABOUT GLOBAL
VERSION 16-2(83) 4-2-73 BY JRL CATCH NEW(ITEMEXPR) GIVE ERRMSG
VERSION 16-2(82) 3-19-73 BY JRL REMOVE POPSET
VERSION 16-2(81) 3-16-73 BY JRL BUG #LU# GLOBAL OPERATIONS
VERSION 16-2(80) 3-12-73 BY JRL REMOVE REFERENCES TO GAG SWITCH
VERSION 16-2(79) 3-8-73 BY JRL COMPILE LENGTH IN-LINE IF POSSIBLE
VERSION 16-2(78) 3-7-73 BY JRL STUFF FOR ALLGLOBAL
VERSION 16-2(77) 3-6-73 BY JRL ADD ALLGLOBAL FEATURE
VERSION 16-2(76) 3-6-73 
VERSION 16-2(75) 2-26-73 BY JRL ANOTHER ATTEMPT TO FIX MP RETURN VALUES
VERSION 16-2(74) 2-26-73 
VERSION 16-2(73) 2-26-73 
VERSION 16-2(72) 2-19-73 BY JRL NOTE SUPERFLUOUS LEAP ROUTINES AS NOOPS
VERSION 16-2(71) 2-12-73 BY JRL ..RVAL NOW AN XX TYPE THING
VERSION 16-2(70) 2-12-73 
VERSION 16-2(69) 2-9-73 
VERSION 16-2(68) 2-7-73 
VERSION 16-2(67) 2-7-73 
VERSION 16-2(66) 2-7-73 BY RHT BUG #LH# ADEPTH PROBLEMS COPPIT,BINCL
VERSION 16-2(65) 2-7-73 
VERSION 16-2(64) 2-7-73 
VERSION 16-2(63) 2-7-73 
VERSION 16-2(62) 2-7-73 BY JRL ROUTINE MPTEMP TO CREATE LOCAL VAR FOR MP
VERSION 16-2(61) 2-6-73 BY JRL ADD ERROR MESSAGE FOR BRACKETED TRIPLE,DERIVED SET IN FOREACH
VERSION 16-2(60) 2-5-73 
VERSION 16-2(59) 2-5-73 BY JRL FIX MP'S FOR SPROUT
VERSION 16-2(58) 2-4-73 BY JRL BUG #LF# ITMREL ALWAYS POPPED STACK INTO AC 4
VERSION 16-2(57) 1-28-73 BY JRL BINDIT AS ALIAS OF UNBND
VERSION 16-2(56) 1-28-73 BY JRL ADD NULL_CONTEXT
VERSION 16-2(55) 1-23-73 BY JRL ANY NOW PREDECLARED "ITEM" FLUSH FROM COMPILER
VERSION 16-2(54) 1-22-73 BY JRL BUG #LE# HANDLE ∀ ?X|X ASSOC X≡FOO
VERSION 16-2(53) 1-22-73 
VERSION 16-2(52) 1-9-73 BY JRL  BUG #KZ# DATUM SHOULD TURN OFF OWN BIT
VERSION 16-2(51) 12-4-72 BY JRL ADD O≡V DERIVED SET
VERSION 16-2(50) 12-1-72 BY JRL BUG #KO# CVLIST SHOULD MARK RESULT AS LIST
VERSION 16-2(49) 12-1-72 
VERSION 16-2(48) 11-26-72 BY JRL ADD POTENTIAL ANYANY≡ANY SEARCH
VERSION 16-2(47) 11-26-72 BY JRL BUG #KN# LTYPCK SHOULD RETURN IP FOR ITEM PRIMARY
VERSION 16-2(46) 11-21-72 BY JRL BUG #KJ# ECHK WITH ITEMVAR GAVE BAD TBITS
VERSION 16-2(45) 11-13-72 BY JRL COMPILE BETTER CODE FOR PROPS
VERSION 16-2(44) 11-10-72 BY JRL ADD EXEC FOR PROPS
VERSION 16-2(43) 11-8-72 BY JRL MAKE BOOLEAN CODE LIKE BOOLEAN FNS
VERSION 16-2(42) 11-8-72 BY JRL CHANGE ISIT TO PRODUCE INTEGER RATHER THAN BOOLEAN
VERSION 16-2(41) 11-7-72 BY JRL ADD BINDING ASSOCIATIVE BOOLEAN
VERSION 16-2(40) 11-6-72 BY JRL BUG #KA# MAKE SURE REMEMBER PARAMS IN CORE
VERSION 16-2(39) 11-6-72 BY JRL JUST GET CNST SEMBLK FOR CVN(DECL ITEM)
VERSION 16-2(38) 11-2-72 BY JRL REFERENCE SETS TO PUT REMOVE SHOULD BE REMOPPED
VERSION 16-2(37) 10-23-72 BY JRL COMPILE ITEM COMPARISONS INLINE
VERSION 16-2(36) 10-22-72 BY JRL MAKE JUMPE JRST TO JUMPN IN FRBOL
VERSION 16-2(35) 10-21-72 BY JRL MAKE CATLST KNOWN TO WORLD
VERSION 16-2(34) 10-20-72 BY RHT BUG #JS# ADJUST ADEPTH IN EVLLST & EVLNLL
VERSION 16-2(33) 10-8-72 BY JRL BUG ##J#O# ADD ROUTINE LTYPCK TO MAKE AE GO TO IP OR SP
VERSION 16-2(32) 10-8-72 BY JRL BUG #JN# STORE DUMMY SEMBLK FOR DERIVED SET IN PARSE STACK
VERSION 16-2(31) 10-3-72 BY JRL OPTIMIZE CVN CODE
VERSION 16-2(30) 10-3-72 BY JRL OPTIMIZE FRCHPOP(DO ONLY WHEN NECESSARY)
VERSION 16-2(29) 10-2-72 BY JRL COMPILE POPTOP ITEM(ECHK) IN-LINE
VERSION 16-2(28) 9-27-72 BY JRL IMPROVE THE STOR1 OPERATION FOR ITEMVARS
VERSION 16-2(27) 9-26-72 BY JRL ADD DATUM(IT,TYPE) FACILITY
VERSION 16-2(26) 9-21-72 BY JRL DECLARE PREDECLARED ITEMS
VERSION 16-2(25) 9-12-72 BY JRL CHANGE DATUM TO USE GDATM PROPERLY
VERSION 16-2(24) 9-11-72 BY JRL MAKE ECVI HONEST ABOUT TYPE
VERSION 16-2(23) 9-8-72 BY JRL ADD CODE TO HANDLE ? LOCALS
VERSION 16-2(22) 9-5-72 BY JRL FORCE STAKIT TO HANDLE ? PARAMETERS
VERSION 16-2(21) 9-1-72 BY KVL MAKE CHECK ON UNTYPED ITEMVARS
VERSION 16-2(20) 8-24-72 BY JRL CHANGE BNDLST TO ALLOW SETS
VERSION 16-2(19) 8-23-72 BY JRL FIX FOR LIST WITH ITEMVAR BUG
VERSION 16-2(18) 8-21-72 BY JRL STORE ITEMS BY EITHER POP OR MOVEM (NOT LEAP CALL)
VERSION 16-2(17) 8-20-72 BY JRL TURN OFF LPFREE IN STAKIT RATHER THAN STITM
VERSION 16-2(16) 8-17-72 BY JRL HANDLE DISPLAY ITEMVAR LOCALS TO FOREACH
VERSION 16-2(15) 8-14-72 BY RHT FIX JRL
VERSION 16-2(14) 8-12-72 BY RHT MODIFY LODPDA TO HANDLE EXTERNAL PROCEDURES
VERSION 16-2(13) 8-10-72 BY JRL ADD REMEMBER, FORGET EXECS
VERSION 16-2(12) 8-9-72 BY JRL CHANGE "GLOBAL" KLUDGE SEE GLBST2
VERSION 16-2(11) 7-2-72 BY JRL ADD LEAPIS AND CLEAN UP LPXISX
VERSION 16-2(10) 6-23-72 BY RHT CHANGE LPSET,LPXISX TO LPSET!LPXISX JUST BEFORE BUG #HW# ON P 16
VERSION 16-2(9) 6-22-72 BY JRL CATCH SET ITMVR←SET
VERSION 16-2(8) 6-21-72 BY RHT FIX THINGS SO PDA NOT FIXED UP AFTER PD IS OUT
VERSION 16-2(7) 6-20-72 BY JRL BUG #HR# USE FIXUP IN LOADING SATIS BLK ADDR RATHER THAN REL. ADDR
VERSION 16-2(6) 6-12-72 BY JRL ADD BNDLST EXEC
VERSION 16-2(5) 6-8-72 BY DCS INSTALL VERSION 16
VERSION 15-2(4) 2-22-72 
VERSION 15-2(3) 2-6-72 BY DCS BUG #FN# SAFE ... ARRAY ITEMVAR BUG
VERSION 15-2(2) 2-5-72 BY DCS BUG #GJ# ADD LSTON LISTING CONTROL STUFF
VERSION 15-2(1) 12-2-71 BY DCS INSTALL VERSION NUMBER

⊗;
SUBTTL	Leap Generators.
	LSTON	(LEAP)
	NOGEN
BEGIN	LEAP
DSCR -- LEAP EXECS
SEE Comment below, and later, for sketchy details
⊗
COMMENT ⊗

These are the generators to handle the LEAP constructs.  Supposedly,
 everything is conditionally assembled so that if LEAPSW is not
 on, you will get a smaller, faster and less elegant compiler.

The SET and ITEM expression manipulators really just call run time
 routines to stack things on some pseudo-stack.  The various Bool-
 ean and operational operators are then implemented as calls on
 the runtime interpreter.  At compiler time, a "copy" of that stack
 is kept around.  This is for purposes of type checking, checking
 to see that things are bound at the right times, etc.
The first section of this code deals with this compile-time stack.
 Every time a LEAP type primary is scanned, either STSET or STITM
 is called to place the token on the stack and to pass the things
 off to the runtime routines.  Any generators designed to make use
 of this stack mechanism should be careful to adjust things.

⊗

;VARIOUS MACRO DEFINITIONS FOR US.....


DEFINE	STAKCHECK (X,Y) <
	IFDIF <Y><>,<MOVNI D,X>
	IFIDN <Y><>,<MOVEI D,X>
	PUSHJ	P,STCHK
	>
DEFINE  CONCHK <
	TLNN	A,CNSTR
	ERR	<RETRIEVAL - CONSTRUCTION FAILURE>,1
	>
DEFINE RETCHK <
	TLNN	A,RETRV
	ERR	<RETRIEVAL - CONSTRUCTION FAILURE>,1
>

DEFINE SETCHK (N) <
	IFDIF <N><>,<MOVEI D,N>
	PUSHJ	P,CHKSET	;SEE IF REQUIRED NUMBER OF SETS
>
;BITS FOR LOCAL ITEMVAR ADDRESSES in FOREACH SATISFIER BLOCK
CDISP ←← 100000			;THIS PARM NEEDS A DISPLAY CALCULATION
MPPAR	←← 200000		;THIS IS ? FORMAL PARAMETER
POTUNB	←← 400000		;THIS IS A ? LOCAL

;VARIOUS BIT DEFINITIONS FOR THE LEAP RUNTIME STACK.
;SEVERAL (THOSE ***'ED) ARE PASSED ON TO THE RUNTIMES -- CAREFUL.

	LPSET	←←	1		;THIS IS A SET *********
	BINDING	←←	2		;THIS IS A LOCAL BEING BOUND ********
	BOUND	←←	4		;THIS IS A LOCAL THAT IS BOUND ********

	LPXISX	←← 	20		;THIS IS A LIST, LPSET ALSO ON ****
	DUMSEM  ←←      40		;THE LEAP STACK ENTRY IS A DUMMY

	↑↑LPITM	←←	40000		;AN ITEM.
	RETRV	←←	20000		;RETRIEVAL CONTEXT IS OK.
	CNSTR	←←	10000		;CONSTRUCTION CONTEXT IS OK.
	LPDMY	←←	4000		;THIS IS A BRAND NEW, MADE-
					;UP LOCAL NUMBER. FOR BRACKETED
					;TRIPLE OR DERIVED SET WITHIN FOREACH
	STACKET	←←	2000		;THIS THING IS REALLY STACKED ....
	LPNUL	←←	1000		; "PHI" LPSET ON ALSO
;FBIND AND QBIND NOW DEFINED IN HEAD
;	FBIND	←←	100		;BIND ITVMR AS IN BIND X⊗Y≡Z
;	QBIND	←←	200		;? ITMVR AS IN BIND X⊗Y≡Z

	BRACKET	←←	400000		;THIS IS A BRACKETED SEARCH ****
					; **** MUST BE SIGN BIT FOR RUNTIMES
					;**** (ONLY)
GLOC <
	GLBSRC   ←←      200000		;THIS IS A GLOBAL SEARCH ******
>;GLOC
	FOREA	←←	40000		;THIS IS INSIDE A FOREACH LIST 
					; (BUT NOT USED)
	SETOP	←←	20000		;THIS IS A SET OPERATION. 


	ATTPOS ←←	6		;POSITIONS OF TYPE BITS.
					;IN CONTROL WORD.
	OBJPOS	←←	3
	VALPOS	←←	0

;NOW FOR THE DEFINITIONS OF ALL THE RUNTIME ROUTINES.

	DEFINE RUNTIM ' (X,Y) <
	L'X ←← MYCOUNT!GLOFLG
	IFDIF <Y><>,<MYCOUNT←←MYCOUNT+Y>
	IFIDN <Y><>,<MYCOUNT←←MYCOUNT+1>
	GLOFLG←←0
	>
DEFINE GLO <
GLOC <
	GLOFLG ←← 400000
>;GLOC
>
	MYCOUNT ←←0
	GLOFLG ←←0

GLO	RUNTIM	TRIPLES 		;0--ORDINARY TRIPLE SEARCHES

	RUNTIM	NOOP1,7			;1-7 NO LONGER USED.

	RUNTIM	STSRC,2			;THE SET SEARCHES ?
	RUNTIM	FRCHGO			;12--BEGINNING OF FOREACH LIST.
	RUNTIM	FRCHPOP			;13--POP SATISFIERS INTO CORE
	RUNTIM	FRLOOP			;14--LOOP BACK FOR MORE (FOREACH STATE.)
	RUNTIM	FRFAL			;15--BOOLEAN FALSE.
GLO	RUNTIM	MAKE			;16--MAKE
GLO	RUNTIM	BMAKE			;17--BRACKETED TRIPLE MAKE.
GLO	RUNTIM	ERAS			;20--ERASE ROUTINES.

	RUNTIM	NOOP2,7			;21-27 NO LONGER USED

GLO	RUNTIM	ISTRIP			;30-BOOLEAN "IS THIS A BRACKETED TRIPLE"
GLO	RUNTIM	SELECT,3		;31-33--SELECTORS.
	RUNTIM	CORPOP			;34 --MOVE CORE TO SATISFIER TABLE
GLO	RUNTIM	LDERIV,3		;35-37--DERIVED SETS DURING FOREACH LISTS.
GLO	RUNTIM	DERIV,3			;40-42--DERIVED SETS, NOT DURING FOREACH.
GLO	RUNTIM	DELETE			;43 -DELETE THIS ITEM.
GLO	RUNTIM	NEWITM			;44--MAKE A NEW ONE.
GLO	RUNTIM	NEWARITH		;45--MAKE A NEW ARITHMETIC TIEM.
GLO	RUNTIM	NEWRY			;46--MAKE A NEW ARRAY ITEM.
	RUNTIM	FRELS			;47--RELEASE THE FOREACH BLOCK
	RUNTIM	STPUT			;50--PUT
	RUNTIM	STREM			;51--REMOVE
	RUNTIM	SIP			;52--SET MAKERS{}.
	RUNTIM	STIN			;53--BOOLEAN A ε S?
	RUNTIM	SETCUNT			;54--LENGTH OF A SET OR LIST
	RUNTIM	STUNT			;55--COP OF A SET
	RUNTIM	STUNI			;56--SET UNION
	RUNTIM	STINT			;57--SET INTERSECTION
	RUNTIM	STMIN			;60--SET SUBTRACTION.
	RUNTIM	STORE			;61--STORE A SET OR ITEM
	RUNTIM	STORBUTDONTREMOVE	;62--EXPRESSION STORE(LEAVE ON STACK)
	RUNTIM	NOOP3			;63--NO-OP USED TO BE POPTOP
	RUNTIM	NOOPA			;64--NO-OP USED TO BE POP OFF SET
	RUNTIM	SETREL,6		;65-72 SET RELATIONS.
GLO	RUNTIM	ISIT			;73--A⊗O≡V ?

	RUNTIM	NOOP4,7			;74-102 NO LONGER IN USE

GLO	RUNTIM	BRTRIP			;103-[A⊗O≡V] AND LEAVE ON STACK.

	RUNTIM  NOOP5,7			;104-112 NO LONGER IN USE

GLO	RUNTIM	ITMRY			;113--THE TWO GUYS FOR MARKING ARRAYS.
	RUNTIM	ITMYR			;114
	RUNTIM	STLOP			;115--LOP OFF AN ITEM FROM A SET.
GLO	RUNTIM	BNDTRP			;116--BIND X ⊗ BIND Y≡ BIND Z (BOOLEAN)
	RUNTIM	SETCOP			;117--COPY A FORMAL SET (ADDRESS IN TAC1)
	RUNTIM	SETRCL			;120--RECLAIM A FORMAL SET ( "" )
	RUNTIM	CATLST			;121--CONCATENATE TWO LISTS
	RUNTIM  PUTAFT			;122--PUT AFTER ITEM
	RUNTIM	PUTBEF			;123--PUT BEFORE ITEM
	RUNTIM	SELFET			;124--SELECT LIST ELEMENT
	RUNTIM	TSBLST			;125--TO SUBLIST
	RUNTIM	FSBLST			;126--FOR SUBLIST
	RUNTIM	SETLST			;127--TRANSFORM LIST TO SET CVSET
	RUNTIM	RPLAC			;130--REPLACE ELEMENT OF LIST
	RUNTIM	REMX			;131--REMOVE INDEXED
	RUNTIM	REMALL			;132--REMOVE ALL 
	RUNTIM  PUTXA			;133--PUT AFTER INDEXED
	RUNTIM	PUTXB			;134--PUT BEFORE INDEXED
	RUNTIM	LSTMAK			;135--ADD TO TEMPORARY LIST {{}}
	RUNTIM	MATCAL			;136--CALL A MATCHING PROCEDURE
	RUNTIM	STK4VL			;137--STACK A ? LOCAL
	RUNTIM	STKQPR			;140--STACK A ? LOCAL AS AN MP ARGUMENT

;;FOLLOWING FOR LPCALLS FROM OTHER SOURCE_FILES

↑LCATLS ←← LCATLS			;RETURN MUST COPY RESULT
↑LSTKQP ←← LSTKQP			;CALARG-STACKS QUES PARAMS
↑LFRLOO ←← LFRLOO			;LOOP CODE MUST BE ABLE TO LOOP BACK
↑LFRELS ←← LFRELS			;DONE ETC, MUST BE ABLE TO EXIT FOREACH
↑LITMRY	←← LITMRY			;ARRAY DECLARATION
↑LITMYR	←← LITMYR			;ARRAY DECLARATION
↑LSETCO ←← LSETCO			;COPY SET FORMALS
↑LSETRC ←← LSETRC			;RECLAIM SET FORMALS

ZERODATA (LEAP VARIABLES)

;MPSTAK A QSTACK OF ALL MATCHING PROCEDURES WHOSE ENDS HAVE NOT
;BEEN SEEN
↑↑MPSTAK:0

;MPVSTK A QSTACK OF XWD ?TABLE ADDR,STATIC LEVEL OF MATCH PROC
↑↑MPVSTK:0

;MPQSTK: A QSTACK FOR ? ITEMVAR PARAMS TO MATCHING PROCEDURE
↑↑MPQSTK: 0

;LEAPIS -- ZERO IF NO LEAP CONSTRUCTS, -1 IF LEAP USED BY COMPILED PROG.
↑↑LEAPIS: 0

;SATADR -- CONTAINS ADDR FIXUP FOR SATISFIER BLOCK FOR FRCHGO
↓SATADR: 0
;BBWORD,INDEX4 used in STCHK to give type bits to ? FOREACH locals
↓BBWORD: 0
↓INDEX4: 0

;BYTES -- a parameter to LPCALL, specifies type bits, etc.  I don't
;    really understand it
↑↑BYTES: 0

↓FFSAVE: 0	;SAVE FF SOMETIMES

;LEABEG -- LEAP "push-down stack" -- used to model the runtime stack,
;    keep track of things
↓LEABEG: BLOCK	40

;LEAPSK -- LEABEG "PDP" -- points to last LEABEG entry
↑↑LEAPSK: 0

;DATBITS + HOLDS TYPE BITS FOR DATUM CONSTRUCT
DATBITS: 0
;HLDCNT - COUNT OF ?FOREACH LOCALS IN SEARCH
;HLD- SEMBLK POINTERS FOR ABOVE, TO HANDLE MISERABLE
; 	∀ ?X | X⊗X≡FOO DO
↓HLDCNT: 0
↓HLD: BLOCK 3

;LEPGLB -- counter set when LEAP operation preceded by GLOBAL
;When the operation is scanned (NEW,⊗,DELETE,DATUM,etc) this value is pushed
;onto the GLBSTK qstack. This is so that constructs such as
; GLOBAL NEW( DATUM (x)) is handled correctly.
↑↑LEPGLB: 0

;GLBSTK A QSTACK TO HANDLE GLOBAL CONSTRUCTS.
↑↑GLBSTK: 0

;ALLGLO -- indicates all leap operations are to be considered global
↑↑ALLGLO: 0

;LOCALCOUNT -- number of bound locals in a FOREACH call
↓LOCALCOUNT: 0

;LOCBEG -- QTAK descriptor into LOCST's QSTACK for FRCHGO call --
;    first collects local names, then puts them out after call
;    see FTRPRM for similar mechanism
↓LOCBEG: 0

;LOCST -- the QPUSH/POP descriptor for the stack described above
;    in LOCBEG
↓LOCST:  0

↓MADEUPLOCALS:	0  ;TEMP IN BRACKETED TRIPLES CODE

;MKFLAG -- tells bracketed triple stuff it's inside a MAKE
↓MKFLAG: 0

;PARBEG -- a temporary pointer into LEABEG stack sometimes
↓PARBEG:  0

;PNBEG, PNLST, PNMSW -- temps for PNAMES stuff in compiler
↑↑PNBEG: 0		;QTAK pointer for PNLST
↑↑PNLST: 0		;qstack for printnames
↑↑PNMSW: 0		;non-zero if pnames required
;ITMSTK - Q-STACK FOR ITEM#'S,TYPES,ITMBEG,ITMCNT ALSO  ASSOC.
↑↑ITMSTK:	0	;QSTACK containing item-type,,item
↑↑ITMBEG:	0	;QTAK pointer for ITMSTK
↑↑ITMCNT:	0	;count of all items including GLOBALS
;HOLDPT - CROCK FOR REFERENCE LIST PARAMS. TO LEAP
;LORSET - QSTACK, TOP ELEM.INDICATES IF MAKING LIST OR SET see sip
;REMASET: FLAG ON IF REMOVE ALL CONSTRUCT
↑↑HOLDPT: 0
↑↑LORSET: 0
↑↑REMASET: 0
PHIBLK:	0				;DUMMY SEMANTIC BLOCK FOR SETS ON STACK
NILBLK: 0				;DUMMY SEMANTIC BLOCK FOR LISTS ON STACK
NULLCN: 0				;DUMMY SEMANTIC BLOCK FOR NULL_CONTEXT
↑↑REMCEL: 0				;SAVE ROUTINE NAME REMEMBER,FORGET RESTORE

;NEDPOP - FLAG -1 IF SOME SEARCH (WITHIN FOREACH) HAS POSSIBLY VOIDED THE CURREN
;SATISFIERS IN CORE
NEDPOP: 0

;BNDFLG -FLAG ON IF STCHK HAS SEEN A BIND
BNDFLG: 0

ENDDATA

DSCR LEPINI
CAL PUSHJ FROM GENINI
DES SETS UP ALL LEAP-SPECIFIC VARIABLES BEFORE EACH COMPILATION
⊗

DEFINE NAMEIT(NAME,TYPE,ITNO,SBNAME) <
	HRROI   TEMP,NAME+1
	POP	TEMP,PNAME+1
	POP	TEMP,PNAME
	MOVEWI	(BITS,TYPE)
	MOVE	LPSA,SYMTAB
	PUSHJ	P,SHASH
	PUSHJ	P,ENTERS
	MOVE	PNT,NEWSYM
IFDIF <ITNO><>,<
	PUSH	P,PNT
	MOVEI	A,ITNO
	PUSHJ	P,CREINT
	POP	P,LPSA
	HRRZM	PNT,$VAL2(LPSA)
	>
IFDIF <SBNAME><>,<
	MOVEM	LPSA,SBNAME
>
>

;PREDECLARED ITEM NAMES

UBNAME: XWD	0,7
	POINT	7,.+1
	ASCII	/UNBOUND/
MINAME: XWD	0,6
	POINT	7,.+1
	ASCII	/MAINPI/
NINAME:	XWD	0,3
	POINT	7,.+1
	ASCII	/NIC/
EVNAME: XWD	0,6
	POINT	7,.+1
	ASCII	/EVTYPI/
EV2NAM: XWD	0,12
	POINT	7,.+1
	ASCII	/EVENT_TYPE/
ANYNAM: XWD	0,3
	POINT	7,.+1
	ASCII	/ANY/
BINNAM: XWD	0,6
	POINT	7,.+1
	ASCII	/BINDIT/

ZERODATA(LEAP ITEM SEMBLK PTRS)
↑UBSBLK: 0; BINDIT
↑EVSBLK: 0; EVTYPI
↑ANSBLK: 0; ANY
↑MPSBLK: 0; MAINPI
ENDDATA

↑↑LEPINI:
	QPUSH	(LOCST)
	QPOP	(LOCST)
	MOVE	A,LOCST
	MOVEM	A,LOCBEG
	MOVEI	A,LEABEG-1
	MOVEM	A,LEAPSK
	MOVEI	A,10
	MOVEM	A,ITEMNO	;LEAVE SOME FOR LEAP TO PLAY WITH.
GLOC <
	MOVEI	A,7777		;MAXIMUM GLOBAL ITEM
	MOVEM	A,GITEMNO	;AND RECORD IT.
>;GLOC
	QPUSH	(MPSTAK,[0])
	QPUSH	(ITMSTK)
	QPOP	(ITMSTK)
	MOVE	A,ITMSTK
	MOVEM	A,ITMBEG		;SAVE FOR USING QTAKE
	QPUSH	(MPQSTK,[0])		;FLAG TO MARK END OF MPQSTK
	GETBLK	(PHIBLK)
	MOVEI	A,SET
	MOVEM	A,$TBITS(LPSA)		;DUMMY SEMANTIC BLOCK FOR PHI(NULL SET)
	GETBLK  (NILBLK)
	MOVEI	A,SET!LSTBIT
	MOVEM	A,$TBITS(LPSA)
	GETBLK	(NULLCN)		;DUMMY SEMBLK FOR NULL_CONTEXT
	MOVEI	A,FLOTNG!SET		;CONTEXT
	MOVEM	A,$TBITS(LPSA)
	POPJ	P,

↑↑LPNAME:NAMEIT  (UBNAME,ITEM,UNBND,UBSBLK)	;DECLARE PREDECLARED IDENTIFIERS
	NAMEIT	(MINAME,ITEM,MAINPI,MPSBLK)
	
	NAMEIT	(NINAME,ITEM,NIC)
	NAMEIT	(EVNAME,ITEM,EVTYPI,EVSBLK)
	NAMEIT	(EV2NAM,ITEM,EVTYPI)
	NAMEIT	(ANYNAM,ITEM,0,ANSBLK)
	NAMEIT	(BINNAM,ITEM,UNBND)		;AN ALIAS FOR UNBOUND
	MOVEI	TEMP,RESYM			;SO DONES WILL WORK CORRECTLY
	MOVEM	TEMP,VARB
	POPJ	P,

DSCR LEAPC1, LEAPC2
PRO LEAPC1 LEAPC2
	These routines are called by the LPCALL macro to generate the
	call to LEAP. Both use left half of BYTES to form control
	bits for flag word. LEAPC2 also adds right half of BYTES
	to routine dispatch number.
PAR     A contains the dispatch number  of routine to be called.
⊗
↑LEAPC2:				;LEAP CALL OF FIRST VARIETY.
	ADD	A,BYTES			;USES INDICES COMPUTED BY STCHK
	SKIPA
↑LEAPC1:
	HLL	A,BYTES			;JUST THE TYPES COMPUTED BY STCHK.
	SETOM	LEAPIS			;SOMEONE USED LEAP.
	PUSH	P,LPSA			;
	PUSH	P,TBITS			;SO CAN RESTORE LATER
	PUSH	P,SBITS
	PUSH	P,PNT
	PUSH	P,D
	PUSH	P,A
	PUSHJ	P,ALLSTO		;SO LEAP DOESN'T HAVE TO SAVE ACS
	POP	P,A			;GET FLAG WORD BACK AGAIN
GLOC <
	TRZN	A,400000		;LEGAL GLOBAL OPERATION
	JRST	NGLBOP			;NO.
	PUSH	P,A			;SAVE OVER QSTAK STUFF.
	QPOP	(GLBSTK)
	MOVE	B,A
	POP	P,A
	SKIPN	ALLGLO		;EVERYTHING GLOBAL??
	CAIE	B,0			;PREFACED BY GLOBAL?
	TLO	A,GLBSRC		;YES.
NGLBOP:	
>;GLOC
	PUSHJ	P,CREINT		;AN INTEGER CONSTANT
	EMIT	<MOVE 5,NOUSAC>		;LOAD FLAG WITH CONTROL BITS, ROUTINE NAME
	SETZM	BYTES			;FOR NEXT TIME
	XCALL	(LEAP)
	POP	P,D
	POP	P,PNT			;RESTORE 
	POP	P,SBITS
	POP	P,TBITS
	POP 	P,LPSA
	POPJ	P,			;EXIT

DSCR STSET
PRO STSET
	STSET, STITM exec routines called whenever a set or item is scanned.
	Stacks entry onto LEAPSK and generates actual stack for previous top
	of LEAPSK if any unless within foreach statement.
⊗

↑STSET: ↑STITM:				;CALLED EACH TIME A SET OR ITEM IS SCANNED
	GETSEM	(1)			;SEMANTICS OF ITEM OR SET
	TLNE	FF,LPPROG		;A FOREACH IN PROGRESS?
	JRST	JUSTAK			;YES -- DO NOT STACK ON RUNTIME STACK
	PUSH	P,PNT
	MOVE	D,LEAPSK
	CAIL	D,LEABEG
	PUSHJ	P,STAKIT		;STACK THE PREVIOUS THING.
	POP	P,PNT
	PUSHJ	P,GETAD
	TLNE	SBITS,LPFREE		;NOT FREE NOW, IS IT?
	ERR	<FREE ITEMVAR IN BAD SPOT>,1 ; WE MUST BE INSIDE A BOOLEAN SINCE
					;LPPROG IS OFF, THEREFORE CAN'T USE
					;UNBOUND LOCALS.
JUSTAK:	HRRZI	A,(PNT)
	TLO	A,RETRV!CNSTR		;TURN ALL THESE ON INITIALLY.
	TLNE	SBITS,LPFRCH!FREEBD	;A LOCAL IN THIS FOREACH?
	TLO	A,BOUND			;SAY BOUND 
	TLNE	SBITS,LPFREE		;A FREE LOCAL?
	TLC	A,BOUND!BINDING		;SAY  BINDING ∧ ¬BOUND
;FOLLOWING INSTRUCTION REMOVED SO THAT MATCHING PROCEDURES MAY KNOW IF
;THERE PARAMS ARE UNBOUND (LPFREE ON);
;THE CODE IN STCHK HAS BEEN ALTERED ACCORDINGLY
;	MOVEM	SBITS,$SBITS(PNT)	;IN CASE IT WAS CHANGED.
	TLNE	SBITS,FREEBD		;A ? LOCAL
	TLZ	A,BINDING		;A FREE ? LOCAL IS NEITHER BOUND NOR BINDING
	TRNE	TBITS,ITEM!ITMVAR	;WHICH LEAP TYPE?
	JRST	[TLO	A,LPITM			;AN ITEM
		 JRST TYPKWN]
	TLO	A,LPSET			;A SET.
	TRNE	TBITS,LSTBIT					
	TLO	A,LPXISX		;A LIST

TYPKWN:	AOS	B,LEAPSK		;INCREMENT STACK POINTER.
	CAIL	B,LEABEG+MAXLOC	;GONE TOO FAR?
	ERR	<LEAP PUSH-DOWN OVERFLOW>,1
	MOVEM	A,(B)			;STORE THE ENTRY.
; THE FOLLOWING HACK IS TO ALLOW COMPLICATED SET OR LIST EXPRESSIONS TO
; BE ARGUMENTS TO NEW. SINCE NEW GETS TYPE OF EXPRESSION FROM PARSE STACK
	TLNE	SBITS,INUSE		;IF NOT A TEMP DON'T BOTHER
	TRNE	TBITS,ITEM!ITMVAR	;IF ITEM DON'T BOTHER
	POPJ	P,
	MOVE	A,PHIBLK		;ASSUME SET
	TRNE	TBITS,LSTBIT
	MOVE	A,NILBLK		;DUMMY LIST SEMBLK
	MOVEM	A,GENRIG+1		;NEW PARSE STACK ENTRY
	POPJ	P,

↑QUESET:SKIPA	A,[QBIND,,0]		;A ? TYPE OF ASSOCIATIVE BOOLEAN
↑FRESET: 				;AN ASSOCIATIVE BOOLEAN OF BIND FORM
	HRLZI	A,FBIND			;THE BIT
	TLNE	FF,LPPROG		;INSIDE FOREACH
	ERR	<BIND  OR ? NOT VALID WITHIN FOREACH>,1
	ORM	A,@LEAPSK
	POPJ	P,


COMMENT @
HERE ARE THE PEOPLE WHO LOOK AT THE COMPILE TIME STACK.

LASCHK	-- MAKES SURE THAT TOP OF COMPILE STACK IS REALLY
	 STACKED -- THIS IS FOR CASE STATEMENTS,EXPR. CONDITIONALS. ETC.
STCHK	-- GUARANTEES THAT N (PASSED IN D) ARGUMENTS ARE IN THE RIGHT
	ORDER ON THE RUNTIME STACK.  THIS IS ONLY COMPLICATED WHEN
	PARSING A FOREACH LIST, SINCE THIS IS THE ONLY CIRCUMSTANCE
	IN WHICH REAL STACKING IS DEFERED.

	THE REASON REAL STACKING IS DEFERRED DURING FOREACH LISTS IS
	THE FOLLOWING:

FOREACH X,Y,Z |  A⊗X≡[B⊗Y≡Z] DO  .....

GETS CHANGED INTO --

FOREACH X,Y,Z | [B⊗Y≡Z]=Q AND A⊗X≡Q DO .....


WITH THE PARTICULAR FORM OF INTERPRETER DESIGNED FOR THESE THINGS,
THERE CAN BE NOTHING REMEMBERED IN THE STACK OVER
A SEARCH OPERATION (E.G. OVER THE "AND" IN THE REARRANGED EXAMPLE ABOVE.


@

↑↑OKSTACK: MOVE 	D,LEAPSK	;CHECK TO SEE IF TOP OF STACK
	CAIL	D,LEABEG	;IS REALLY STACKED.
	 JRST	 STAKIT
	POPJ	P,

;; #JO# BY JRL 10-8-72 ROUTINE TO TAKE AE TO EITHER IP OR SP
↑LTYPCK:			;MAKE AE GO TO EITHER SP OR IP
	MOVE	A,@LEAPSK	;TOP OF STACK ENTRY
	MOVE	B,%NIP		;ASSUME ITEM
;; #KN# 11-26-72 FOLLOWING INSTR WAS ERRONEOUSLY TLNN
	TLNE	A,LPSET!LPXISX	;LIST OR SET?
	MOVE	B,%NSP		;YES
	MOVEM	B,PARRIG+1	;INTO PARSE STACK
	POPJ	P,
;; #JO#


↑BNDITM:
	PUSHJ	P,OKSTACK		;MAKE SURE ITS STACKED
	SOS	B,LEAPSK	;TOP OF STACK
	CAIE	B,LEABEG-1	;MAKE SURE WAS ONLY 1 ITEM
	ERR	<MUST BE ITEM EXPRESSION>
	MOVE	A,1(B)		;OLD TOP OF STACK
	TLNN	A,LPITM		;TEST IF REALLY ITEM
	ERR	<BNDITM- ASSOC EXPR MUST BE ITEM>,1
	POPJ	P,

↑BNDLST:
	PUSHJ	P,OKSTACK
	SOS	B,LEAPSK	;TOP OF STACK
	CAIE	B,LEABEG-1	;MAKE SURE ONLY SINGLE LIST
	ERR	<MUST BE LIST EXPRESSION>,1
	MOVE	A,1(B)		;OLD TOP OF STACK
	TLNN	A,LPSET
	ERR	<LIST EXPRESSION REQUIRED>,1
	POPJ	P,


LASCHK:	MOVE	D,LEAPSK		;CURRENT TOP OF STACK.
	PUSHJ	P,STAKIT		;MAKE SURE THAT IT IS STACKED.
	PUSH	P,[1]			;ONE PARAMETER.
	MOVE	A,LEAPSK
	MOVEM	A,PARBEG		;ONE PARAMETER.
	JRST	POP0			;GO DO THE STUFF ON 
					;THE COMPILE-TIME STACK.
STCHK:	PUSH	P,D			;SAVE NUMBER OF PARAMS TO CHECK.
	MOVMS	D
	MOVNI	D,-1(D)			;NUMBER OF PARAMETERS -1
	ADD	D,LEAPSK		;TO GET BEGINNING.
	MOVEM	D,PARBEG		;THE FIRST PARAMETER.
	TLNE	FF,LPPROG		;MAKES A BIG DIFFERENCE.
	JRST	LPCHK			;ALAS, YES.

	MOVE	D,LEAPSK
	PUSH	P,PNT			;STAKIT WILL DESTROY
	PUSHJ	P,STAKIT		;STACK THE LAST THING.
	POP	P,PNT			;RESTORE IT
POP0:	MOVE	D,PARBEG		;THE FIRST PARAMETER
	MOVE	SBITS2,LEAPSK		;THE LAST PARAMETER.
	SETOM	B			;ALL BITS ON (RETRV,LPITM, ETC)
	SETZM	TBITS2			;THE BITS FOR THE CONTROL WORD.
	MOVE	PNT2,[POINT 3,TBITS2,8]	;TO GET ATTPOS ON AN IDPB....
	SETZM	BNDFLG			;NO FBIND YET
POP1:	CAILE	D,(SBITS2)		;DONE?
	JRST	POP1B			;YES
	MOVE	A,(D)			;TOP OF STACK.
	TLNN	A,FBIND!QBIND
        JRST    PP1A
	SETOM	BNDFLG			;HAVE SEEN A BIND.
	TLO	A,BINDING		;THIS IS BEING BOUND
PP1A:	HLRZ	C,A			;GET LEFT HALF BITS.
	IDPB	C,PNT2			;STORE THE THREE BITS AWAY IN "BYTES"
	ANDB	A,B			;AND CREATE THE HAVOC EVERYONE WANTS.
					;ACTUALLY THIS KEEPS TRACK 
					;OF CNSTR,RETRV, ETC.
	TRZ	A,-1			;NOTHING THERE.
	SOS	ADEPTH			;SINCE THIS IS A PARAMETER,
					; IT WILL DISAPPEAR
	SOS	LEAPSK			;DECREMENT STACK POINTER.
	TLNN	A,RETRV!CNSTR		;HAD BETTER BE ONE OR THE OTHER.
	ERR	<RETRIEVAL - CONSTRUCTION FAILURE>,1
					;SIGNAL RETRIEVAL-CONSTR. FAILURE
	AOJA	D,POP1			;LOOP UNTIL ALL PARAMETERS DONE.
POP1B:	TLNE	TBITS2,BINDING⊗ATTPOS
	TRO	TBITS2,1		;START TO MAKE UP AN INCREMENT.
	TLNE	TBITS2,BINDING⊗OBJPOS
	TRO	TBITS2,2
	TLNE	TBITS2,BINDING⊗VALPOS
	TRO	TBITS2,4
	TLNN	FF,LPPROG		;ONLY RECORD LEFT HALF IF FOREACH.
	TLZ	TBITS2,444		;THIS IS THE "BOUND" BITS EVERYWHERE.
	MOVEM	TBITS2,BYTES		;AND THE RESULTS.
	POP	P,D
	SKIPE	BNDFLG			;ANY BIND OPS?
	TLO	A,FBIND			;YES
	JUMPGE	D,CPOPJ		

	AOS	LEAPSK
	MOVEM	A,@LEAPSK
	AOS	ADEPTH			;THIS IS NOT A PARAM YET....
	POPJ	P,



LPCHK:	CAIN	D,LEABEG		;THE END OF THE LEAP STACK?
	JRST	GOODY			;YES -- EVERYTHING IS MUCH SIMPLER.

	MOVEI	D,LEABEG		;PREPARE TO RAMBLE THROUGH.
POP3:	CAMN	D,PARBEG		;ARE WE UP TO THE PARAMETERS YET
	JRST	GOODY			;YES -- WITHOUT A HITCH.
	MOVE	A,(D)			;PICK UP STACK ELEMENT.
	TLNN	A,STACKET		;IS IT REALLY STACKED ?
	AOJA	D,POP3			;LOOP -- NO
	MOVE	D,LEAPSK		;TROUBLE -- GET TOP OF STACK.
					;SOMETHING BEFORE THE PARAMETERS
					;IS STACKED. WE MUST POP OFF EVERYTHING
					;SINCE WITHIN FOREACH NOTHING CAN BE
					;REMEMBERED ON THE STACK OVER CALL TO LEAP
POP4:	CAIL	D,LEABEG		;LOOP UNTIL ALL ARE POPPED.
	JRST	POP8			;ALL DONE -- NOW STACK BACK ON.!!
	PUSH	P,POPEND		;IN LINE CALL.
POPIT:	MOVE	A,(D)			;STACK ELEMENT
	TLZN	A,STACKET		;ON STACK ?
	POPJ	P,			;NO
	PUSH	P,A
	PUSHJ	P,GETCRTMP		;GET A TEMP.
	MOVEI	PNT,(LPSA)		;SINCE GETCRTMP RETURNS ANSWER IN LPSA.
	EMIT	(<POP RP,NOUSAC>)
	SOS	ADEPTH			;WE HAVE POPPED.
	POP	P,A
	HRRI	A,(PNT)			;POINTER TO TEMP.
	MOVEM	A,(D)		;SAVE BACK ON STACK.
POPEND:	POPJ	P,.+1
	SOJA	D,POP4			;LOOP UNTIL DONE.


GOODY:	MOVE	D,PARBEG		;HERE WHEN STACK BEHIND 
					;PARBEG IS IN GOOD
	ADDI	D,1			;SHAPE....
G2:	CAMLE	D,LEAPSK		;ALL DONE?
	JRST	POP8			;YES ...
	MOVE	C,@PARBEG		;THE FIRST PARAMETER.
	XOR	C,(D)			;XOR WITH THE CURRENT PARAMETER.
	TLNN	C,STACKET		;ARE THEY STACKED DIFFERENTLY?
	AOJA	D,G2			;NO -- LOOP
	MOVE	D,LEAPSK		;TROUBLE -- GO THROUGH AND POP.
G1:	CAMGE	D,PARBEG
	JRST	POP8			;ALL DONE
	PUSHJ	P,POPIT			;DO THE POPS
	SOJA	D,G1


POP8:	MOVE	D,PARBEG		;WHERE IT ALL BEGINS.
	HRRI	C,(BINDING!BOUND)⊗ATTPOS
	MOVEM	C,BBWORD		;INITIAL BINDING BITS WILL RIGHT SHIFT
					;EACH TIME THROUGH LOOP
	MOVEI	C,1			;INITIAL DISPATCH INCREMENT
	MOVEM	C,INDEX4
	JRST	POP9
POP90:	MOVE	C,BBWORD
	LSH	C,-3
	MOVEM	C,BBWORD
	MOVE	C,INDEX4
	LSH	C,1
	MOVEM	C,INDEX4
POP9:	CAMG	D,LEAPSK		;ALL DONE?
	JRST	POP9A			;NO.
;; #LE# DON'T TURN OFF LPFREE TOO EARLY
	SKIPN	B,HLDCNT		;ANY ?LOCALS?
	JRST	POP0			;NO -- ALL DONE
	SETZM	HLDCNT			;FOR NEXT TIME
	MOVE	SBITS,[LPFREE,,0]
	MOVE	PNT,HLD-1(B)		;THE LAST ONE.
	ANDCAM	SBITS,$SBITS(PNT)	;TURN OFF LPFREE BIT
	SOJG	B,.-2
	JRST	POP0			;ALL DONE WITH THIS KLUDGE
POP9A:	PUSH	P,POPRET		;IN LINE CALL.
STAKIT:	MOVE	PNT,(D)			;GET STACK ELEMENT.
	TLOE	PNT,STACKET		;ALREADY STACKED?
POPRET:	POPJ	P,POP11			;DONE.
	MOVEM	PNT,(D)
	PUSH	P,POPAA			;IN LINE CALL.
PREPAR:	PUSHJ	P,GETAD		;GET GOOD BITS.
	TLNE	PNT,FBIND!QBIND		;BIND ITMVR?
	JRST	BINDQF
	TLZ	SBITS,LPFREE		;A FREE LOCAL?
	TLNN	SBITS,FREEBD		;DON'T SAVE YET IF FREEBD
					;BECAUSE OF CONSTRUCT X⊗X≡Y
	MOVEM	SBITS,$SBITS(PNT)	;NO LONGER FREE
	TRNE	TBITS,ITEM
	TLNE	TBITS,FORMAL!SBSCRP
	JRST	[TRNE TBITS,ITMVAR
		 TLNN SBITS,LPFRCH!FREEBD
		 JRST NONEW
		 TLNE FF,LPPROG		;ONLY GET LOCAL NUMBER IF FOREACH
		 JRST NEWSS		;IN PROGRESS
		 JRST NONEW]
NEWSS:
	HRR	PNT,$VAL2(PNT)		;THE POINTER TO ITEM NUMBER
					;OR LOCAL NUMBER......
	PUSHJ	P,GETAD
NONEW:
	SETZM	A
	TLNE	PNT,LPDMY
	HRRZ	A,(D)			; A MADE UP NUMBER.
	TLNE	PNT,LPDMY!LPNUL
	PUSHJ	P,CREINT
POP10:	GENMOV	(ACCESS,0)			;STACK THE THINGS.
POPAA:	POPJ	P,.+1
	GENMOV	(STACK,0)		;WILL CAUSE REMOP TOO.
	POPJ	P,
POP11:	MOVE	PNT,(D)			;GET ITEMVAR SEMBLK BACK
	MOVE	SBITS,$SBITS(PNT)	;GET SBITS BACK
	TLNN	SBITS,LPFREE		;IF STILL FREE MUST BE FREEBD
	AOJA	D,POP90			;LOOP BACK
	TLNN	SBITS,FREEBD		;ERROR CHECK
	ERR	<DRYROT - POP11>
	AOS	A,HLDCNT
	MOVEM	PNT,HLD-1(A)		;-1 SINCE INDEX STARTS AT ZERO
	HRL	A,BBWORD
	HRR	A,INDEX4
	PUSHJ	P,CREINT
	GENMOV	(STACK,0)		;STACK BINDING BITS,DISPATCH INCREMENT
	SOS	ADEPTH			;THIS WILL GO AWAY IMMEDIATELY
	PUSH	P,BYTES			;PROTEXT BYTES OVER LPCALL
	LPCALL  (STK4VL)		;STACK VAL OR LOCAL NUMBER
	POP	P,BYTES			;RESTORE BYTES
	AOJA	D,POP90			;LOOP BACK
BINDQF: PUSH   P,PNT		;SAVE LEFT HALF BITS
	GENMOV (INCOR)			;MAKE SURE IN CORE
	HLL	PNT,(P)			;IN CASE INCOR CHANGED PNT.
	TLNE	PNT,QBIND	
	JRST	[SETOM MPFLAG
		 HRLI PNT,POTUNB
		 PUSHJ	P,FTRADR	;WANT POTUNB IN LEFT HALF
		 SETZM MPFLAG
		 JRST BINDQ1]
	HRRZS	PNT			;SINCE ADRINS WILL USE BITS LH
	PUSHJ	P,ADRINS		;WILL STACK THE ADDRESS
BINDQ1:	HLL	PNT,(P)			;GET LEFT HALF BITS BACK
	SUB	P,X11			;POP OFF OLD PNT
	POPJ	P,

CHKSET:					;CHECK IF PARAMETERS SETS
	MOVE	C,LEAPSK		;TOP ELEM. OF STACK
	HRLZI	A,LPXISX		;BIT WE'RE LOOKING FOR
CHKSLP:	TDNE	A,(C)			;A LIST?
	ERR	<ERROR - ILLEGAL LIST OPERATION>,1
	SUBI	C,1
	SOJG	D,CHKSLP
	POPJ	P,			;RETURN ALL O.K.
DSCR CHKSAT -
	check to see if we have to pop satisfiers into core within
	associative context of FOREACH
⊗
↑↑CHKSAT:				;
	SKIPN 	NEDPOP			;DO WE NEED IT;
	POPJ	P,
	SETZM	NEDPOP			;DON'T NEED IT NOW
	LPCALL	(FRCHPOP)
	POPJ	P,

;FOREACH STATEMENT HANDLERS.
DSCR FRCHGO, ENTITV, BOPREP, FRBOL, STSRC, BTRIP, DERIV, etc.
PRO FRCHGO ENTITV BOPREP FRBOL STSRC FID1 FRCH1 FRCH2 BTRIP DERIV
⊗
COMMENT ⊗
	THE FIRST THING WE DO IS CAUSE THE ADDRESS OF THE SCB POINTER
	VARIABLE TO BE STACKED. WE THEN CAUSE THE LOADING OF TAC1 WITH
	THE ADDRESS OF THE SATISFIER BLOCK CONTAINING:
	1. A JRST TO THE END (OUTSIDE) OF THE LOOP.
	2. THE NUMBER OF LOCAL ITEMVARS SPECIFIED IN THE SEARCH.
	3. THE ADDRESSES (1 BY 1) OF ALL THE LOCAL ITEMVARS.
		THUS, IF A LOCAL IS REFERED TO BY NUMBER (SAY 3)
		ITS CORE STORAGE ADDRESS CAN BE FOUND BY LOOKING
		IN THE THIRD ENTRY IN THIS LIST
	We then emit the call to start leap up, followed by a jump
	around the  satisfier block followed by the satisfier block
	itself (see above);
⊗

SCBNAM: XWD 0,6				;every scb variable has the same name
        POINT 7,.+1
        ASCII /SCB.../
↑EACH4:					;DECLARE SCB VARIABLE
	NAMEIT	(SCBNAM,<INTEGR!FLOTNG>)
	PUSHJ	P,GETAD
	EMIT	<MOVEI TAC1,NOUSAC>
	HRLZI	C,14			;ADDR IS 14
	EMIT	<PUSH P,NOUSAC!USADDR!NORLC!NOADDR>
	POPJ	P,
↑FRCHGO:
	SETZM	NEDPOP			;DON'T NEED POP YET
	PUSHJ	P,FRCHT			;IN FOR LOOP DOMAIN -- 
					;MAKE A BLOCK. ETC.
	MOVEI	B,$DATA(LPSA)		;PLACE TO PUT FIXUP FOR JUMP OUT.
	TLO	FF,LPPROG		;LEAP IN PROGRESS.
	MOVE	C,PCNT			;CALC. ADDR OF SATISFIER BLOCK
; ##HR## JRL 6-20-72 USE FIXUP RATHER THAT RELATIVE ADDR. SO NEEDNEXT OK
	MOVEM	C,SATADR		;FOR FIXUP LATER
	EMIT	<MOVEI TAC1,NORLC!NOADDR!NOUSAC> ;LOAD ADDRESS OF SATIS BLOCK
; ##HR##
	LPCALL	(FRCHGO)		;CALL TO SET UP FOREACH SEARCH.
	MOVE	C,PCNT			;CALC. ADDRESS FOR JUMP OVER SATIS BLOCK
	ADD	C,LOCALCOUNT		;ONE WORD PER LOCAL
	ADDI	C,3			;FOR JRST AND COUNT OF LOCALS
	MOVSI	C,(C)			;PREPARE FOR EMIT
	EMIT	<JRST ,	USADDR!NOUSAC>  ;JRST AROUND SATIS BLOCK
;NOW GENERATE SATISFIER BLOCK
	HRLZ	PNT2,PCNT
	MOVEM	PNT2,(B)		;FIXUP FOR JUMP OUT.
;;  #HR# USE FIXUP 
	HRR	PNT2,SATADR		;PLACE TO FIXUP
	MOVS	B,PNT2
	PUSHJ	P,FBOUT			;FIXUP MOVEI 14,
;; #HR#
	EMIT	(<JRST NOUSAC!NOADDR>)	;WHERE TO GO WHEN DONE.
	HRL	C,LOCALCOUNT
	EMIT	(<NOUSAC!NORLC!USADDR>)	;COUNT OF LOCALS.
	MOVE	B,LOCBEG		;THE POINTER FOR QTAK
ANO:	QTAKE	(LOCST)			;GET FIRST LOCAL.
	POPJ	P,			;ALL DONE.
	MOVE	PNT,A
	PUSHJ	P,GETAD			;GET SEMANTICS
	MOVEI	A,0			;COLLECT BITS FOR LEFT HALF
	TLNE	TBITS,MPBIND		; A ? PARAMETER
	TRO	A,MPPAR			;YES
	TLNE	SBITS,FREEBD		;POTENTIALLY UNBOUND?
	TRO	A,POTUNB		;YES
	TRNN	SBITS,DLFLDM		;A DISPLAY TYPE THING?
	JRST	SIMITM			;NO.
	TLNE	TBITS,REFRNC		;A REFERENCE PARAMETER?
	TRO	A,20			;PUT ON INDIRECT BIT
	LDB	TEMP,[LEVPOINT <SBITS>]
	CAMN	TEMP,CDLEV		;SAME DISPLAY LEVEL?
	JRST	SIMITM			;YES, SIMPLE CASE AGAIN
	TRO	A,CDISP			;THIS IS A DISPLAY TYPE THING
	SUB	TEMP,CDLEV		;CALCULATE DISPLAY DIFFERENCE
	MOVMS	TEMP
	IORI	A,(TEMP)		;PUT INTO INDEX FIELD
	HRLI	A,JSFIX!NOUSAC		;BITS FOR EMITER
	TLNN	TBITS,REFRNC!VALUE	;A FORMAL PARAMETER?
	JRST	SIMIT2			;NO.
	HRRZ	TEMP,$ADR(PNT)		;STACK DISPLACEMENT
	MOVN	TEMP,TEMP		;NEGATE
	SUBI	TEMP,1			;FOR RETURN ADDR
	HRL	C,TEMP
	HRLI	A,USADDR!NOUSAC!NORLC
	JRST	SIMIT2
SIMITM:	HRLI	A,NOUSAC		;STANDARD CASE
SIMIT2:
	MOVSS	A			;RIGHT IS LEFT AND VICE VERSA
	PUSHJ	P,EMITER
	JRST	ANO			;LOOP UNTIL DONE.




↑↑QLOCAL:
	GETSEM (0)			;A ? FOREACH LOCAL
	TLNE	SBITS,LPFRCH!FREEBD	;ALREADY IN LIST?
	ERR	<SAME LOCAL ITEMVAR IN BINDING LIST>,1
	TLO	SBITS,FREEBD
	MOVEM	SBITS,$SBITS(PNT)
	POPJ	P,
↑ENTITV:				;RECORD THE NAME OF A LOCAL.
	GETSEM	(1)		;SEMANTICS OF ITMVAR.
	MOVE	PNT2,PNT
	TLNE	SBITS,LPFREE
	ERR	<SAME LOCAL APPEARS MORE THAN ONCE IN BINDING LIST>,1
	TLO	SBITS,LPFREE!LPFRCH	;TURN ON.
	TLNE	SBITS,FREEBD		;A ? LOCAL
	TLZ	SBITS,LPFRCH		;YES
	MOVEM	SBITS,$SBITS(PNT)	;IN MEMORY
	AOS	A,LOCALCOUNT
	CAILE	A,MAXLOC
	ERR	<TOO MANY LOCALS IN FOREACH LIST>,1
	PUSHJ	P,CREINT		;MAKE AN INTEGER.
	MOVEM	PNT,$VAL2(PNT2)		;SAVE FOR FUTURE GENERATIONS.
	QPUSH	(LOCST,GENLEF+1)	;SAVE FOR END.
	POPJ	P,


↑BOPREP:			;PREPARE FOR BOOLEAN INSIDE A FOREACH SPEC.
	PUSHJ	P,CHKSAT	;UPDATE CORE LOCATIONS IF NECESSARY
	TLZ	FF,LPPROG	;TURN OFF THE "LEAP" BIT.
	POPJ	P,


↑FRBOL:				;BOOLEAN DONE INSIDE FOREACH LIST.
	PUSH	P,PCNT		; SAVE PCNT
	PUSHJ	P,ALLSTO	;CLEAR ALL AC'S
	POP	P,A
	CAME	A,PCNT		;SHOULD BE THE SAME
	ERR	<DRYROT-AT LEAP:FRBOL>,1
	PUSHJ	P,BONOT		;TO JUMP ON TRUE
	PUSHJ	P,STIF		;GO GENERATE CODE.
;	LPCALL	(FRTRU)		;FOREACH TRUE HANDLER.
; WE WILL NOW SIMPLY GEN JRST	; (WILL SKIP OVER THE "FALSE" CALL FOLLOWING)
	LPCALL	(FRFAL)		;FOREACH FALSE HANDLER.
	HRR	B,PCNT
	HLL	B,GENRIG	;FIXUP FOR FALSE PART.
	JUMPL	B,.+2		;If BE evaluates to FALSE no JRST TRUE
	PUSHJ	P,FBOUT
	SETOM	GENRIG		;FOR THE FOREACH GUY TO NOTICE THAT CODE HAS GONE OUT.
	TLO	FF,LPPROG		;TURN IT BACK ON.
	POPJ	P,

↑STSRC:				;FOREACH SPEC. OF FORM  " X IN SET "
	MOVE	A,@LEAPSK	;SEE IF DUMMY ITEM(FROM DERIVED SETS)
	TLNE	A,LPDMY
	ERR	<DERIVED SET WITHIN FOREACH WILL DO WRONG THING>,1
	STAKCHECK (2)		;TWO ARGS.
	RETCHK			;RETRIEVAL TYPES NECESSARY
	MOVSI	A,SETOP		;TELL FOREACH
	IORM	A,BYTES
	LPCALL	(STSRC,,BYTES)	;CALL FOR SEARCH.
	SETOM	NEDPOP		;NEED POP INTO CORE
	SETOM	GENRIG+1	;CODE GONE OUT.
	POPJ	P,
↑FID1:				;TO SAY NO CODE GONE.
	SETZM	GENRIG+1
	POPJ	P,

↑FRCH1:					;GENERAL SEARCH X⊗Y≡Z
	SKIPE	GENLEF+1		;HAS CODE GONE OUT?
	POPJ	P,			;YES -- WAS A SET SEARCH.
	STAKCHECK (3)			;THREE ARGUMENTS.
					;STCHK COMPUTES THE DIRECTIVE BITS
					;(IN "BYTES" TO TELL LEAP INTERPRETER
					;WHICH THINGS ARE BOUND, FREE, ETC.)
	RETCHK				;RETRIEVAL TYPES NECESSARY
	LPCALL	(TRIPLES)		;AIN'T THAT SIMPLE.
	SETOM	NEDPOP			;NEED TO POP
	POPJ	P,

↑FRCH2:					;LAST SEARCH SPEC. IN THE FOREACH LIST.
	PUSHJ	P,FRCH1			;FOR THE LAST TRIPLE.
	MOVE	A,FRBLK			;SAVE SEMANTICS OF ASSDO
	MOVEM	A,GENRIG
	PUSHJ	P,CHKSAT		;CALL TO PUT SATISFIERS DOWN IN CORE.
	MOVE	SP,LOCALCOUNT		;GET READY TO PROCESS LOCALS.
LGO:	QPOP	(LOCST)			;GET TOP ONE
	MOVE	SBITS,$SBITS(A)		;
	MOVE 	TBITS,$TBITS(A)
	MOVE	LPSA,A			;FOR THE ERROR HANDLER TO PRINT OUT.
	TLZE	SBITS,LPFRCH!FREEBD	;NO LONGER IN A FOREACH.
	TLZE	SBITS,LPFREE
	ERR	<STRANGE USE OF LOCAL: >,3	;NEVER WAS CITED.
	MOVEM	SBITS,$SBITS(A)
	SOJG	SP,LGO

	SETZM	LOCALCOUNT	;RESTART THE COUNT FOR NEXT TIME.
	SETZM	MADEUPLOCALS	;DITTO.
	TLZ	FF,LPPROG		;AT LAST DONE.
	JRST	ENDFOR			;IN FOR LOOP CODE -- MAY PUT OUT
					;CALLS IF COROUTINES NEEDED.



↑BTRIP:					;BRACKETED TRIPLE.
	STAKCHECK	(3)		;3 PARAMS TO BRACKETED TRIPLE.
	TLNN	FF,LPPROG		;INSIDE FOREACH SEARCH
	JRST	NOFR			;NO
	AOS	A,MADEUPLOCALS		;MAKE A NEW "MADE UP" LOCAL.
	ADD	A,LOCALCOUNT
	PUSH	P,A			;"A" IS NEW LOCAL NUMBER.
	PUSHJ	P,CREINT		;MAKE AN INTEGER
	EMIT	(<PUSH	RP,NOUSAC>)	;AND GIVE THE NUMBER.
	MOVSI	B,BRACKET
	IORM	B,BYTES			;TO TELL THERUNTIMES.
	LPCALL	(TRIPLES)		;SEARCH FOR THE BRACKETED TRIPLE.
					;LEAP INTERP. WILL PUT ITEM # IN AS
					;SATISFIER OF THE MADEUP LOCAL.
	POP	P,A
	HRLI	A,LPDMY!LPITM!BOUND!RETRV ;NOW RECORD THE DUMMY LOCAL NUMBER.
					;NOTE DUMMY NUMBER IN RIGHT HALF;
	JRST	BFIN			;ALL DONE.



NOFR:	SKIPE	MKFLAG			;IN A MAKE STATEMENT?
	JRST	MKB			;YES
	TLNE	A,FBIND	
	ERR	<BIND NOT VALID WITH BRACKETED TRIPLES>,1
	RETCHK				;RETRIEVAL TYPES NECESSARY
	LPCALL	(BRTRIP)		;JUST LOOK FOR IT.
	HRLZI	A,LPITM!STACKET!RETRV	;RESULT IS AN ITEM.
	JRST	BFINA

MKB:	CONCHK				;CONSTRUCTION TYPES NECESSARY
	LPCALL	(BMAKE)			;CALL TO MAKE THE BRACKETED TRIPLE.
	HRLZI	A,LPITM!STACKET!CNSTR	;AND RESULT IS ITEM.

BFINA:	AOS	ADEPTH			;STACK HAS A RESULT ON IT.
BFIN:	AOS	B,LEAPSK		;PUT THIS BACK -- STCHK SOS'ED IT.
	MOVEM	A,(B)			;STORE THE NEW TOP OF STACK.
	POPJ	P,

↑DERIV:					;DERIVED SETS.
	PUSH	P,B			;PARSER INDEX OF TYPE.
	STAKCHECK (2)			;TWO PARAMETERS.
	TLNE	A,FBIND
	ERR	<BIND OR ? NOT VALID IN DERIVED SETS>,1
	MOVE	B,(P)			;GET THE PARSER INDEX.
	CAIN	B,2			;IF THIS KINDS
	ERR	<P * Q NOT IMPLEMENTED>,1
	MOVEI	A,BINDING
	JRST	DERNDX(B)		;WHICH DERIVED SET
DERNDX:	JRST	DERXOR			;A ⊗ O
	JRST	DERQUOT			;A ' V
	JRST	DERXOR			;WILL TREAT A*O AS A⊗O
; O ≡ V
	LDB	C,[POINT 9,BYTES,17-VALPOS];WILL HAVE TO SHIFT BITS STACKCHECK
					;COMPUTED
	LSH	C,-3			;ATT→OBJ→VAL
	DPB	C,[POINT 6,BYTES,17-VALPOS]
	DPB	A,[POINT 3,BYTES,17-ATTPOS]
	SOS	(P)			;INDEX SHOULD BE 2
	JRST	NOFUNQ
; A ' V
DERQUOT:LDB	C,[POINT 3,BYTES,17-OBJPOS]
	DPB	C,[POINT 3,BYTES,17-VALPOS]
	DPB	A,[POINT 3,BYTES,17-OBJPOS]
	JRST	NOFUNQ			;SAFE.
; A ⊗ O
DERXOR:	DPB	A,[POINT 3,BYTES,17-VALPOS] ;NEW ITEMVAR.
NOFUNQ:
	TLNN	FF,LPPROG		;FOREACH GOING ?
	JRST 	NODRV			;NO
	AOS	A,MADEUPLOCALS		;MAKE UP A NEW LOCAL NUMBER.
	ADD	A,LOCALCOUNT
	PUSH	P,A
	PUSHJ	P,CREINT		;MAKE AN INTEGER FOR IT.
	EMIT	(<PUSH RP,NOUSAC>)	;PUSH ON STACK .
	LPCALL	(LDERIV,<-1(P)>)	;CALL SEARCHER.  WE HAVE ESSENTIALLY
					;TURNED A ⊗ ( C ⊗ D) ≡ X INTO
					;    C ⊗ D ≡ Y ∧ A ⊗ Y ≡ X
	POP	P,A
	HRLI	A,LPITM!LPDMY!BOUND!RETRV ;RESULT IS AN ITEM DUMMY NUMBER.
	POP	P,B
	JRST	BFIN

NODRV:	LPCALL	(DERIV,<(P)>)		;NOT INSIDE FOREACH -- JUST CALL IT.
	MOVE	A,PHIBLK		;DUMMY SET SEMBLK
;; #JN# BY JRL 10-8-72 FOLLOWING INSTR WAS TO GENRIG INSTEAD OF GENRIG+1
	MOVEM	A,GENRIG+1		;ONTO PARSE STACK
	HRLZI	A,LPSET!STACKET!RETRV	;RESULT IS A SET.
	POP	P,B
	JRST	BFINA
;DATUM HANDLERS
DSCR DDATA, LDATA
PRO DDATA LDATA
⊗
GETITM:				;LOAD TOP OF LEAPSK INTO AC 3
	MOVE	PNT,@LEAPSK	;GET THE LAST THING PUT ON STACK.
	SOS	LEAPSK		;DECREMENT STACK COUNTER.
	TLNN	PNT,LPITM	;HAD BETTER HAVE ITEM
	ERR	<DATUM AND PROPS ONLY VALID FOR ITEM EXPR>,1
	TLNE	PNT,LPDMY
	ERR	<PROPS WON'T FOR BRACKETED TRIPLE WITHIN FOREACH>,1
	SETZM	SBITS		;ZERO OUT SBITS
	TRNE	PNT,-1		;IF WE HAVE A SEMBLK
	PUSHJ	P,GETAD		;GET SEMANTICS OF ITEM.
	SKIPN	TEMP,BITS		;FOR DATUM(IT,TYPE)
	MOVE	TEMP,TBITS
	MOVEM	TEMP,DATBITS
	TLNE	SBITS,LPFREE
	ERR	<DATUM OR PROPS OF UNBOUND ITEMVAR WITHIN FOREACH>,1
	TLNE	FF,LPPROG	;CHECK TO SEE IF FOREACH GOING.
	TLNN	SBITS,LPFRCH!FREEBD;AND THIS THING IS ONE OF THE ITEMVARS.
	SKIPA			;NO -- OK
	PUSHJ  P,CHKSAT
	MOVEI	D,3		;WE NEED THE ITEM IN AC 3
	TLNN	PNT,STACKET
	JRST	[
;;  #NX# WASN'T DOING RIGHT THING BY DATUM(BINDIV,STRING) MAKE SURE
;		GOOD TBITS ARE USED.
		 GENMOV (GET,SPAC!GETD);
		 JRST GOTEN]
	HRL	C,D		;AC NUMBER TO GET IT IN.
	EMIT	<POP RP,NOUSAC!NORLC!USADDR> ; IT WAS ON THE REAL STACK.
	SOSA	ADEPTH		;AND BOOKKEEP THIS.
GOTEN:
	PUSHJ	P,REMOP		;REMOVE THE ITEM NUMBER.
	POPJ	P,

↑DDATA:
↑LDATA:	TLO	FF,FFTEMP	; GET ADDRESS OF DATUM ENTRY.
				;IF FFTEMP IS OFF, GET VALUE OF DATUM ENTRY.
	PUSHJ	P,GETITM
	PUSHJ	P,GETAN0	;BUT GET ANOTHER AC FOR DATUM.
GLOC <
	QPOP	(GLBSTK)	;IF GLOBAL, THEN USE THE OTHER ONE.
	SKIPN	ALLGLO
	SKIPE	A		;USE GLOBAL DATUM?
	JUMPN  A,[HRLI	C,7776	;MAXIMUM ITEM.
		 EMIT	(<CAIG 3,NOUSAC!USADDR!NORLC>)
		 HRLI	C,6000	;GLOBAL BREAK
		 EMIT	(<CAIG 3,NOUSAC!USADDR!NORLC>)
		 XCALL	(DATERR)
		 HRL	C,PCNT	;CHAIN INSTRUCTIONS.
		 SKIPN	NOEMIT
		 EXCH	C,LIBTAB+RGDATM ;GLOBAL DATUM
		 JRST 	DATGO]
>;GLOC
	HRL	C,PCNT
	SKIPN	NOEMIT
	EXCH	C,LIBTAB+RDATM	;WORD TO INDIRECT THROUGH.
DATGO:	
	MOVE 	TBITS,DATBITS
	TRZN	TBITS,LPARRAY
	JRST	NORM		;ITEM TYPE IS NOT AN ARRAY.
;;#FN# DCS 2-6-72 (1-1) SAFE ... ARRAY ITEMVAR X -- X not treated as SAFE
	TLZ	TBITS,-1≠SAFE	;READY FOR NEW TEMP
	TLO	TBITS,SBSCRP	;NEW TEMP WILL BE ARRAY, NOT WITH OWN ON, ETC.
;;#FN#   Replace HRLI TBITS,SBSCRP
	TLZ	FF,FFTEMP	;BUT WE GET THE DESCRIPTOR.
	EMIT	(SKIPN @USADDR)
	XCALL	(LPRYER)	;GETTING AN ARRAY THAT DON'T EXIST.
	JRST	FINOUT

NORM:	MOVE	A,[MOVE @USADDR]	;INSTR. TO PICK UP VALUE.
	TLNE	FF,FFTEMP
	TLO	A,1000		;CHANGE IT TO A MOVEI.
	TRNE	TBITS,STRING	;STRING ITEM?
	HRLI	A,(<HRRO @>)	;HRRO INDIRECT
	PUSHJ	P,EMITER	;AND EMIT THE INSTRUCTION.
FINOUT:	TRZ	TBITS,ITEM!ITMVAR
	TRNN	TBITS,-1	;UNTYPED?
	ERR	(<UNTYPED ITEM OR ITEMVAR OUGHT TO BE TYPED.>,1)
	PUSHJ	P,TYPDEC	;TYPE THE NEW THINGS.
	MOVEM	A,PARRIG	;PARSE TYPE FOR THE PRODUCTION INTERPRETER.
;; #KZ# TURN OFF OWN BIT DATUM(OWNARRAY[I])
	TLZ	TBITS,FORMAL!OWN!MPBIND;RANDOM THINGS MAY BE ON......
	PUSH	P,PNT		;SAVE SEMANTICS OF THING POINTED DO.
	PUSH	P,TBITS		;BECAUSE MARK MASKS SOME THINGS.
	SETZB	TBITS,SBITS	;MAKE SURE WE MAKE AN ARITHMETIC TEMP....
	GENMOV	(MARK,0)	;MAKE A TEMP.
	HRROS	$ACNO(PNT)	;FOR ARRAYS $*$*$*$*$**$*$*$*$*$**$*
	POP	P,TBITS
	POP	P,TEMP
	TLNE	TBITS,SBSCRP	;IF AN ARRAY DATUM,
	MOVEM	TEMP,$VAL(PNT)	;SEE ARRY FOR THE PLACE THIS IS USED.
				;IT IS FOR MAKING A NAME FOR THE ARRAY ERROR UUO.
	MOVEM	TBITS,$TBITS(PNT)	;PUT DOWN THE REAL TYPES.
	TLNE	FF,FFTEMP
	TLC	SBITS,INAC!PTRAC!INDXED	;NORMAL CASE IS TO RETURN POINTER.
	MOVEM	SBITS,$SBITS(PNT)	;AND THE REAL SEMANTIC BITS.
	MOVEM	PNT,GENRIG	;TELL EVERYONE WHO OUGHT TO KNOW.
	POPJ	P,
DSCR - PPSTO,EPPSTO,GETPROP  execs for PROPS
⊗
↑PPROP: SOS	B,LEAPSK	;GET ITEM
	MOVE	PNT,1(B)	;TOP ELEM OF LEAP STACK
	TLNN	PNT,LPITM	;BETTER BE ITEM
	ERR	<PROPS REQUIRES ITEM EXPR ARGUMENT>,1
	TLNE	PNT,STACKED	;STACKED,HOPE NOT!
	JRST	WSSTKD		;TOO BAD
	HRRZM	PNT,GENRIG	;NO JUST PUT IT DOWN
	POPJ	P,
WSSTKD:	MOVEI	D,3		;WANT AC 3
	PUSHJ	P,STORZ		;MAKE SURE WE CAN HAVE IT
	HRLI	C,3
	EMIT	<POP RP,USADDR!NOUSAC!NORLC> ; POP IT OFF
	SOS	ADEPTH		;NO LONGER ON STACK
	MOVEI	TBITS,ITMVAR	;RESULT IS ITEMVAR
	PUSHJ	P,MARKME
	HRRZM	PNT,GENRIG
	POPJ	P,

↑EPPSTO:TLOA	FF,FFTEMP	;EXPR STORE
↑PPSTO:	TLZ	FF,FFTEMP	;JUST STORE
	MOVE	PNT,GENLEF+3	;THE ITEM
	MOVEI	D,3		;WANT ITEM IN AC 3
	GENMOV  (GET,SPAC!GETD)
	PUSHJ	P,REMOP		;REMOP THE TEMP IF NEC.
	HRROS	ACKTAB+3	;PROTECT AC 3
	MOVE	PNT,GENLEF+1	;THE VALUE TO BE STORED
	HRRI	B,INTEGR	;HAD BETTER BE INTEGER
	GENMOV	(GET,INSIST!POSIT!GETD)
	TLNN	FF,FFTEMP	;EXPR STORE?
	JRST	STPROP		;NO.
	PUSHJ	P,MARKINT	;MARK AS TEMP
	MOVEM	PNT,GENRIG+1	;THE RESULT
	JRST	.+2		;SKIP OVER REMOP
STPROP:	PUSHJ	P,REMOP
	HRL	C,PCNT		;FOR FIXUP TO PROPS
GLOC <	QPOP	(GLBSTK)	;GLOBAL PROPS?
	SKIPE	ALLGLO
	JRST	[SKIPN NOEMIT
		 EXCH C,LIBTAB+RGPROPS
		 JRST PPDPB]
	JUMPN	A,[SKIPN NOEMIT
		   EXCH C,LIBTAB+RGPROPS	;FIXUP TO GPROPS
		   JRST PPDPB]
>;GLOC
	SKIPN	NOEMIT
	EXCH	C,LIBTAB+RPROPS ;FIXUP TO PROPS
PPDPB:	EMIT	<DPB ,USADDR>	;STORE VALUE
	HRRZS	ACKTAB+3	;UNPROTECT AC 3
	POPJ	P,

↑GTPROP:
	MOVE	PNT,GENLEF+1	;ITEM INTO AC 3
	MOVEI	D,3
	GENMOV	(GET,SPAC!GETD)
	PUSHJ	P,REMOP		;REMOP THE TEMP
	HRL	C,PCNT		;FOR FIXUP TO PROPS
GLOC <
	QPOP	(GLBSTK)
	SKIPE	ALLGLO
	JRST	PPAGLO
	JUMPN	A,[PPAGLO:SKIPN NOEMIT
		   EXCH C,LIBTAB+RGPROPS
		   JRST GTPR2]
>;GLOC
	SKIPN	NOEMIT
	EXCH	C,LIBTAB+RPROPS
GTPR2:	PUSHJ	P,GETAC		;AC FOR RESULT
	EMIT	<LDB ,USADDR>
	PUSHJ 	P,MARKINT	;MARK AS INTEGER
	MOVEM	PNT,GENRIG+1
	POPJ	P,


; MAKE AND ERASE
DSCR MAKIT, ERAS, MKSET, MAK
PRO MAKIT ERAS MKSET MAK
⊗


↑MAKIT:	JUMPE	B,MAK
↑ERAS:
	STAKCHECK (3)		;THREE ARGUMENTS.
	TLNE	A,FBIND		;BIND NOT VALID
	ERR	<BIND NOT VALID IN ERASE>,1
	RETCHK				;RETRIEVAL TYPES NECESSARY
	TLNN	A,LPITM		;ITEMS ONLY ?
	ERR	<MAKE AND ERASE DO NOT ACCEPT SET ARGUMENTS>,1
	LPCALL	(ERAS)		;ERASE CALL.
	POPJ	P,

↑MKSET:				;GO INTO MAKING MODE.
	SKIPN	B
	SETOM	MKFLAG		;TO DETERMINE IF BRACKETED TRIPLE SHOULD
				;BE MADE, OR RETRIEVED
	POPJ	P,

↑MAK:				;MAKE AN ASSOCIATION.
	SETZM	MKFLAG
	STAKCHECK (3)		;THREE ARGUMENTS.
	TLNE	A,FBIND
	ERR	<BIND NOT VALID IN MAKE>,1
	CONCHK			;CONSTRUCTION TYPES NECESSARY
	LPCALL	(MAKE)		;DOIT
	POPJ	P,

; VARIOUS BOOLEANS.
DSCR STIN, ISTRIP, ISIT, STREL
PRO STIN ISTRIP ISIT STREL
⊗
↑STIN:				; X IN SET ?
	STAKCHECK (2)		;TWO ARGUMETS.
	TLNE	A,FBIND
	ERR	<BIND NOT VALID IN SET BOOLEANS>,1
	RETCHK			;RETRIEVAL TYPES NECESSARY
	XPREP
	LPCALL	(STIN)
	JRST	INTGO1		;MARK AS INTEGER.


↑ISTRIP:			; IS X A BRACKETED TRIPLE ?
	STAKCHECK (1)
	XPREP
	LPCALL	(ISTRIP)	;CALL
	JRST	INTGO		;MARK AN INTEGER AND LET BOOP FIND IT.


↑ISIT:				;A ⊗ B ≡ C ?
	STAKCHECK (3)		;THREE ITEMS.
	RETCHK			;RETRIEVAL TYPES NECESSARY
	TLNE	A,FBIND
	JRST	[XPREP
		 LPCALL(BNDTRP) ;CALL
		 JRST INTGO1]
	XPREP
	LPCALL	(ISIT)		;CALL.
	JRST	INTGO1

↑ITMREL:SOS	B,LEAPSK	;DEC LEAP STACK
	MOVE 	PNT,1(B)		;OLD TOP OF LEAP STACK
	TLNE	PNT,LPDMY
	ERR	<BRACKETED TRIPLE WON'T WORK HERE>,1
	TLNN	PNT,STACKED	;STACKED?
;;#NM# ↓ (1 OF 2) IF A BINDING ITEMVAR MUST LOAD;
	JRST	BINTST		;NO, JUST STORE
	HRRI	FF,0		;DON'T NEED INDX OR DBL
	PUSHJ	P,GETAC		;GET AN AC
;; #LF#  FOLLOWING WAS A HRLI
	HRL	C,D		;THE AC NUMBER
	EMIT	<POP RP,NOUSAC!USADDR!NORLC>
	SOS	ADEPTH		;NO LONGER ON STACK
	HRRI	TBITS,ITMVAR
	PUSHJ	P,MARKME	;MARK AS ITEMVAR TEMP
	JRST	ITMRE2
;; #NM# (2 OF 2) LOAD INTO AC IF ? ITEMVAR
BINTST:				;IF A BINDING ITEMVAR MUST MAKE A TEMP;
	MOVE	TBITS,$TBITS(PNT);
	TLNN	TBITS,MPBIND	; A BINDING PARAM?
	JRST	ITMRE2		; NO.
	GENMOV	(GET,GETD)	;LOAD INTO AC
	HRRI	TBITS,ITMVAR
	PUSHJ	P,MARKME	;MARK AS ITMVAR
;; #NM#
ITMRE2:	HRRZM	PNT,GENRIG+1	
	HRRZM	PNT,GENLEF+1	;BOTH PLACES
	POPJ	P,

↑STREL:				;RELATIONS ON LISTS, SETS AND ITEMS.
	CAIN	B,2		;=?
	JRST    SRELOK		;YES
	CAIN	B,3		;≠?
	JRST	SRELOK		;YES
	HRLZI	A,LPITM!LPXISX  ;INVALID TYPES FOR GTR. LE.
	MOVE	C,LEAPSK	;ADDR. TOP OF PSEUDO STACK
	TDNE	A,(C)		;O.K. RELATION
	JRST	RELERR		;NO.
	TDNN	A,-1(C)		;OTHER ARGUMENT SET?
	JRST	SRELOK		;YES, RELATION IS VALIED
RELERR:	ERR	<INVALID RELATION, CHANGED TO ≠>,1
	MOVEI	B,3		;≠
SRELOK:	PUSH	P,B		;TYPE OF RELATION.
	MOVE	A,@LEAPSK	;TOP OF LEAP STACK
	TLNN	A,LPITM		;AN ITEM?
	JRST	SREOK2		;NO.
	PUSHJ	P,ITMREL	;GET OFF OF LEAP STACK
	SKIPN	PNT,GENLEF+3
	ERR	<DRYROT AT LEAP:SRELOK>,1
	MOVE	TBITS,$TBITS(PNT) ;
	TRNN	TBITS,ITEM!ITMVAR
	ERR	<INVALID ITEM COMPARISON>,1
	TRNE	TBITS,ITEM	;AN ITEMVAR?
	TLNE	TBITS,FORMAL!SBSCRP
	JRST	STMREL
	HRRZ	PNT,$VAL2(PNT)	;GET CONSTANT SEMBLK
	JUMPN	PNT,STMREL
	ERR	<DRYROT AT LEAP:STMREL>
STMREL: MOVEM	PNT,GENLEF+3
	MOVE	PNT,GENLEF+1
	MOVE	TBITS,$TBITS(PNT)
	TRNE	TBITS,ITEM
	TLNE	TBITS,FORMAL!SBSCRP
	JRST	STMRE2
	HRRZ	PNT,$VAL2(PNT)
	MOVEM	PNT,GENLEF+1
STMRE2:
	POP	P,B		;RELATION TYPE
	JRST	IREL		;IN BOOLEAN CODE(EXPRS)
SREOK2:
	STAKCHECK (2)		;TWO ARGUMENTS.
	RETCHK			;RETRIEVAL TYPES NECESSARY
	XPREP
	TLNN	A,LPITM		;ITEMS?
	JRST	SETSES		;NO -- SETS.
	ERR	<INVALID ITEM COMPARISON>,1
;	LPCALL	(<ITMREL-2>,<(P)>)
	JRST	STFIN
SETSES:	TLNN	A,LPSET		;IS IT REALLY A SET.
	ERR	<NO MIXED RELATIONS, PLEASE>,1
	LPCALL	(SETREL,<(P)>)
STFIN:	POP	P,B
	GETBLK	GENRIG+1	;SIMULATE A BOOLEAN
	MOVEM	LPSA,GENRIG
	PUSHJ	P,GOSTO
	EMIT	(<JUMPE NOADDR>)
	MOVE	A,[XWD 1,$VAL]
	JRST	BODON		;FINISH OUT WITH BOOLEANS

DSCR DELT, SIPGO, STPRIM, ECVI, STLOP, PUTIN, LPPHI, etc.
PRO DELT, SIPGO, STPRIM SIP1 STCNT STUNT ECVI ECVN STLOP
PRO STMIN STINT STUNI PUTIN LPPHI
⊗

↑DELT:				;DELETE THE ITEM.
	STAKCHECK (1)
	RETCHK			;RETRIEVAL TYPES NECESSARY
	LPCALL	(DELETE)
	POPJ	P,

; START A LIST IN THE MAKING.
↑LIPGO:	SKIPA	A,[-1]			;TO STORE IN LORSET
; START A SET IN THE MAKING. I.E.  A← { ONE,TWO,THREE }
↑SIPGO:
	SETZ	A,			;TO STORE IN LORSET
	QPUSH	(LORSET)
	PUSHJ	P,OKSTACK
	MOVEM	FF,FFSAVE		;SAVE THE FLAG WORD.
	TLZ	FF,LPPROG
	MOVEI	A,0
	PUSHJ	P,CREINT
	EMIT	(<PUSH RP,NOUSAC>)
	AOS	ADEPTH
	POPJ	P,

↑STPRIM:				;ALL DONE -- JUST MARK "STACK"
	MOVSI	A,LPPROG
	TDNE	A,FFSAVE
	TLO	FF,LPPROG
	MOVE	C,PHIBLK		;DUMMY SET SEMBLK
	HRLZI	B,LPSET!STACKET!RETRV	;THESE ARE THE NEW BITS.
	HLRZ	A,LORSET		;ADDRESS TOP ENTRY
	SKIPE	(A)			;SKIP IF SET
	JRST	[TLO	B,LPXISX		;REALLY A LIST
		 MOVE C,NILBLK		;DUMMY LIST SEMBLK
		 JRST .+1]
	MOVEM	C,GENRIG		;FAKE UP PARSE STACK
	QPOP	(LORSET)
	HLLZ	A,B
	JRST	BFIN

↑SIP1:					;CALLED FOR EACH ELEMENT OF SET LIST.
	STAKCHECK	(1)
	HLRZ	A,LORSET
	SKIPE	A,(A)
	JRST	[LPCALL (LSTMAK)
		 POPJ	P,]
	LPCALL	(SIP)
	POPJ	P,



↑STCNT:					;LENGTH OF SET (# OF ELEMENTS)
	MOVE	PNT,@LEAPSK
	MOVE	SBITS,$SBITS(PNT)
	TLNN	PNT,STACKED		;ALREADY STACKED?
	TLNE	SBITS,ARTEMP		;OR A TEMP?
	JRST	LPCNT			;CALL LEAP DO DO IT
	PUSHJ	P,GETAC			;GET AN AC TO PLAY WITH
	EMIT	<HLRE ,>		;FETCH THE LENGTH
	SOS	LEAPSK			;SO LONGER ON LEAP STACK
	JRST	INTGO			;MAKE INTO INTEGER
LPCNT:					;WILL HAVE TO CALL LEAP
	STAKCHECK	(1)
INFENT:	XPREP
	LPCALL	(SETCUNT)		;ENTER HERE FROM PROCESSING INF.
INTGO:	PUSHJ	P,MARKINT	;MARK AN INTEGER.
	HRRI	TBITS,INTEGR
	MOVEM	TBITS,$TBITS(PNT)       ;IN CASE WAS A TEMP ITMVAR OR SOMETHING
					;SINCE MARK DOESN'T CHANGE TBITS OF TEMP
	MOVEM	PNT,GENRIG
	POPJ	P,

INTGO1: PUSHJ	P,MARKINT	;MARK AS INTEGER
	HRRI	TBITS,INTEGR
	MOVEM	TBITS,$TBITS(PNT)
	MOVEM	PNT,GENRIG+1
	POPJ	P,


↑STUNT:				;COP OF SET (GET ONE ELEMENT)
	STAKCHECK	(1)
	LPCALL	(STUNT)
	HRLZI	A,LPITM!STACKET!RETRV!CNSTR		;A NEW ITEM.
	JRST	BFINA


↑ECVI:	PUSHJ	P,OKSTACK
	MOVE	PNT,GENLEF+1		;CONVERT TO ITEM.
	GENMOV	(GET,GETD!INSIST,INTEGR)	
	PUSH	P,D			;THE AC ITS IN
	PUSHJ	P,REMOP			;REMOP THE INTEGER TEMP
	POP	P,D
	MOVEI	TBITS,ITMVAR
	PUSHJ	P,MARKME		;THIS IS REALLY AN ITEMVAR
	MOVE	A,PNT
	HRLI	A,LPITM!RETRV!CNSTR
	JRST	LPREC			;PUT BACK ON STACK.

↑ECVN:  MOVE	PNT,@LEAPSK		;TOP OF LEAP STACK
	TLNE	PNT,LPSET!LPXISX		;BETTER NOT BE SET;
	ERR	<CVN ONLY VALID FOR ITEMS>,1
	TLNE	PNT,LPDMY
	ERR	<BRACKETED TRIPLE INVALID HERE>,1
	TLNN	PNT,STACKET		;ALREADY STACKED?
	JRST	GTITM
	STAKCHECK (1)			;ALREADY ON RUNTIME STACK
	PUSHJ	P,GETAC			;GET A RESULT NUMBER.
	HRL	C,D
	EMIT	<POP RP,NOUSAC!NORLC!USADDR>
	JRST	INTGO			;GO MAKE AN INTEGER
					; (SEE "LLEN" IN STRING.)
GTITM:
	MOVE	TBITS,$TBITS(PNT)	;TYPE BITS OF QUANTITY
	TRNE	TBITS,ITEM		;DECLARED ITEM?
	JRST	[TRNE TBITS,FORMAL!SBSCRP
		 JRST .+1
		 HRRZ TEMP,$VAL2(PNT)	;THE CONSTANT SEMBLK
		 JUMPE TEMP,.+1		;NOT THERE
		 MOVEM TEMP,GENRIG	;THE CONSTANT SEMBLK
		 SOS LEAPSK		;NO LONGER ON LEAP STACK
		 POPJ P,]
	GENMOV (GET,GETD)		;NOT STACKED
	SOS LEAPSK			;NO LONGER ON LEAP STACK
	JRST	INTGO			;MAKE INTO INTEGER


FIRREF:	SOS	PNT,LEAPSK		;THERE SHOULD BE SOMETHING THERE.
	MOVE	PNT,1(PNT)
	TRNE	PNT,-1
	TLNE	PNT,STACKET		;NOT STACKED, I HOPE
	ERR	<NEEDS REFERENCE ARG>,1,CPOPJ
	PUSHJ	P,GETAD
	TLNE	SBITS,INDXED!FIXARR	;OK IF CALC. SBSCRP.
	JRST	FIROK
	TLNE	SBITS,ARTEMP!STTEMP	;NOT THESE
	ERR	<NEEDS REFERENCE ARG>,1
FIROK:	GENMOV	(ACCESS,0)
	EMIT	<MOVEI TAC1,NOUSAC>
	PUSHJ	P,REMOP
	POPJ	P,

↑STLOP:	PUSHJ	P,FIRREF		;FIRST ARG BY REF....
	LPCALL	(STLOP)
XXLP:	HRLZI	A,LPITM!STACKET!RETRV
	JRST	BFINA



FOR II    ⊂ (STMIN,STINT,STUNI),<
↑II:	SETCHK	(2)		;NEEDS TWO SET ARGUMENTS
	STAKCHECK (2,LEAVE)
	LPCALL	(II)
	POPJ	P,	>


↑REMAST: SETOM	REMASET		;INDICATES REMOVE ALL

	POPJ	P,	

↑PUTIN:				;PUT AND REMOVE.
	PUSH	P,B		;PARSER INDEX
	PUSHJ	P,FIRREF	;GO GET IT.
	STAKCHECK	(1)	;FOR THE ITEM.
	POP	P,D
	SKIPN	D
	JRST	[
		LPCALL	(STPUT)
		POPJ	P,]
	SKIPE	REMASET
	JRST	[SETZM	REMASET
		 LPCALL	(REMALL)
		 POPJ	P,]
	LPCALL	(STREM)
	POPJ	P,


; THINGS TO MAKE NIL AND PHI WORK.  THEY JUST MARK THE COMPILE STACK.
↑STKNIL: SKIPA	C,NILBLK			;SEMANTIC BLOCK NIL LIST
↑LPPHI:	MOVE 	C,PHIBLK			;GET SEMANTIC BLOCK
	MOVEM 	C,GENRIG
	MOVE	A,[XWD LPSET!LPNUL!RETRV,0]
	CAME	C,PHIBLK
	TLO	A,LPXISX
LPREC:				;ENTER HERE FROM ECVI
	PUSHJ	P,BFIN
	TLNE	FF,LPPROG
	POPJ	P,			;FOREACH GOING ON.
	MOVEI	D,-1(B)		;THING BEFORE THE "NIL"
	CAIL	D,LEABEG	;ANYTHINGTO STACK ?
	JRST	STAKIT			;STACK IT.
	POPJ	P,
	LSTON	(LEAP)
DSCR PUTINL,HLDPNT,REMXD,REPLCX LISTGT
PRO	PUTINL,HLDPNT,REMXD,REPLCX,LISTGT
⊗
COMMENT ⊗
	PUTINL is exec routine which is called to generate PUT AFTER 
	REMXD is exec routine which generates REMOVE indx FROM list
	HLDPNT simply takes argument off of LEAPSK and saves it in 
	location HOLDPNT.
	LISTGT causes TEMP to be loaded from list variable whose semantics
	are in HOLDPNT
⊗
↑PUTINL:			;PUT INTO LIST (AFTER,BEFORE)
	PUSH	P,B		;PARSER INDEX
	GETSEM	(1)		;SEMANTICS OF AE
	TRNN	TBITS,ITEM!ITMVAR!SET	;SET TO TAKE CARE OF COP,LOP 	; ITEM OR ARITHMETIC?
	JRST	PUTXAB		;ARITHMETIC
	PUSHJ	P,LISTGT	;CROCK TO GET LIST ARGUMENT
	STAKCHECK (2)		;TWO ITEM ARGUMENTS
;HERE WE SHOULD PROBABLY CHECK TO MAKE SURE BOTH ITEMS NOT SETS.
	TLNN	A,LPITM		;BOTH ITEMS?
	ERR	<SET OR LIST WHERE ITEM EXPECTED>,1
	POP	P,B		;POP INDEX
	LPCALL	(PUTAFT,<B>)	;CALL LEAP
	POPJ	P,			;RETURN TO PARSE

PUTXAB: STAKCHECK (1)		;ITEM ARGUMENT
	TLNN	A,LPITM		;REALLY AN ITEM?
	ERR	<SET OR LIST WHERE ITEM EXPECTED>,1
	AOS	ADEPTH		;SINCE STAKCHECK DECREMENTED.
	GETSEM	(1)		;INDEX AMOUNT
	GENMOV	(STACK,INSIST,INTEGR)	;STACK AND COERCE TO INTEGER
	PUSHJ	P,LISTGT
	MOVNI	B,2
	ADDM	B,ADEPTH	;PARAMETERS WILL DISAPEAR
	POP	P,B		;PARSER INDEX
	LPCALL	(PUTXA,<B>)
	POPJ	P,


LISTGT: MOVE	A,HOLDPT	;PNTR FOR LIST SEMBLK
	AOS	B,LEAPSK	;WILL STACK IT TO USE FIRREF
	MOVEM	A,(B)		;STACK IT
	MOVE 	A,$TBITS(A)
	TRNN	A,LSTBIT
	ERR	<LIST DESTINATION REQUIRED>,1
	PUSHJ	P,FIRREF	;LIST ARGUMENT
	POPJ	P,


↑HLDPNT:SOS	B,LEAPSK	;TAKE OFF OF LEAP STACK
	MOVE	A,1(B)
	MOVEM	A,HOLDPT	;SAVE LIST SEMBLK POINTER
	POPJ	P,




↑REMXD:				;REMOVE INDEXED
	GETSEM	(3)		;INDEX
	GENMOV	(STACK,INSIST,INTEGR)	;COERCE AND STACK
	PUSHJ	P,FIRREF	;FOR LIST PARAMETER
	SOS	ADEPTH		;PARAMETER WILL GO AWAY
	LPCALL	(REMX)		;FOR CALL TO LEAP
	POPJ	P,		;RETURN TO PARSE


↑REPLCX: STAKCHECK (1)		;ITEM
	AOS	ADEPTH		;SINCE STACKCHEK DECREMENTED.
	GETSEM	(3)		;INDEX
	GENMOV	(STACK,INSIST,INTEGR)	;COERCE AND STACK
	GETSEM	(4)		;LIST ARGUMENT   
	TRNN	TBITS,LSTBIT
	ERR	<REPLACE REQUIRES LIST PARAMETER>,1
	GENMOVE (ACCESS,0)	;LIST PARAMETER
	EMIT	<MOVEI TAC1,NOUSAC>
	MOVNI	A,2
	ADDM	A,ADEPTH	;TWO PARAMS WILL GO AWAY.
	LPCALL	(RPLAC)
	POPJ	P,		;RETURN TO PARSE
DSCR CVLS,LSSUB,SELIP,SELSBL 
⊗
COMMENT ⊗ CVLS GENERATES THE CODE TO CONVERT A LIST EXPRESSION INTO 
	A SET EXPRESSION AND VICE_VERSA.
	REFINF - puts semantics of list variable on LENSTR q-stack for
	appropriate handling of ∞
⊗

↑CVLS:				;CONVERT LIST←→SET
; B 1 IF CVLIST, 0 IF CVSET
	MOVE	A,GENLEF+1
	MOVEM	A,GENRIG	;TWIDDLE PARSE STACK
	MOVE	A,@LEAPSK
	TLNN	A,LPSET
	ERR	<CVLIST CVSET REQUIRE SET, LIST ARGUMENTS>,1
	JUMPE	B,[STAKCHECK (1);LIST
		   LPCALL (SETLST)
		   HRLZI  A,LPSET!STACKET!RETRV!CNSTR
		   JRST BFINA]
;; #KO# BY JRL CVLIST SHOULD MARK RESULT AS LIST
	HRLZI	A,LPSET!LPXISX!RETRV!CNSTR
	IORM	A,@LEAPSK
	POPJ	P,

↑↑REFINF:			;REFERENCE FORM FOR INF
	GETSEM	(1)		;THE LIST
	MOVE	A,PNT
	HRLI	A,777000
	JRST 	REFENT

↑↑LSSUB:				;SET UP TO HANDLE INF.
	PUSHJ	P,OKSTACK
	HRRO	A,ADEPTH
REFENT:	QPUSH	(LENSTR)		;SAME AS SUBSTRING USES
	AOS	LENCNT
	POPJ	P,
↑ELSSUB:			;DISABLE INF.
	QPOP	(LENSTR)
	SOS	LENCNT
	POPJ	P,
↑↑LINF:				;HANDLE INF. WITHIN LIST SELECTION OR REPLACE
	TLNN	A,777		;REFERENCE FORM
	JRST	[HRRZ	PNT,A
		JRST REFLNG]    ;PERM. SET, WE CAN FIND THE LENGTH DIRECTLY
	MOVN	C,ADEPTH	;CURRENT ADEPTH
	ADDI	C,(A)		;RELATIVE STACK POSITION
	LSH	C,=18		;PREPARE FOR EMIT
	PUSH	P,C		;SAVE IN CASE DESTROYED BY ROUTINES
	PUSHJ	P,GETAC		;GET AN ACCUM. TO PLAY WITH
	PUSHJ	P,MARKINT	;LENGTH IS AN INTEGER
	MOVEM	PNT,GENRIG	;PARSER EXPECTS A SEMBLK
	POP	P,C		;IN CASE GETAC OR MARKINT DESTROYED
	HRLI	D,P		;PREPARE FOR EMIT
	EMIT	<HLRE	,USADDR!NORLC!USX>
	HRL	C,D		;PREPARE FOR MOVMS
  	EMIT	<MOVM	,USADDR!NORLC>
	POPJ	P,

REFLNG:				;TO DETERMINE LENGTH OF PERMANENT SET
	PUSH	P,PNT		;REFERENCE TO SET,
	PUSHJ	P,GETAC		;ACCUM TO PLAY WITH
	PUSHJ	P,MARKINT	;LENGTH RETURNED IS INTEGER
	MOVEM	PNT,GENRIG	;PRODUCTIONS EXPECT IT HERE
	POP	P,PNT
	MOVE    SBITS,$SBITS(PNT);GET SBITS
	EMIT	<HLRE >
	POPJ	P,


↑SELIP:				;SELECT ITEM INDEXED FROM LIST
	STAKCHECK (1)		;FOR LIST ARGUMENT
	AOS	ADEPTH		;SINCE STACKCHEK DECREMENTED.
	GETSEM	(1)		;INDEX
	GENMOV	(STACK,INSIST,INTEGR)
	LPCALL	(SELFETCH)
	SOS	ADEPTH		;PARAM WILL GO AWAY.
	HRLZI	A,LPITM!STACKET!RETRV!CNSTR
	JRST	BFIN


↑SELSBL:			;FOR TAKING A SUBLIST
	SUBI	B,4		;PARSER INDEX 0 IF TO ,1 IF FOR
	SKIPGE	B		;CHECK TO MAKE SURE TO OR FOR
	ERR	<ERROR- SUBLIST SYNTAX, FOR ASSUMED>,1
	PUSH	P,B		;SAVE FOR LATER USE
	STAKCHECK	(1)		;FOR LIST
	AOS	ADEPTH		;SINCE DECREMENTED.
	GETSEM	(3)		;FOR FIRST ARG.
	GENMOV	(STACK,INSIST,INTEGR)	;FOR FIRST INDEX
	GETSEM	(1)		;FOR SECOND INDEX
	GENMOV	(STACK,INSIST,INTEGR)
	MOVNI	A,3		;STACK WILL BE THREE LESS
	ADDM	A,ADEPTH
	POP	P,B		;RESTORE INDEX
	CAIE	B,0		;TO?
	JRST	[LPCALL (FSBLST)
		 HRLZI	A,LPSET!LPXISX!STACKET!RETRV!CNSTR
		JRST BFINA]
	LPCALL	(TSBLST)
	HRLZI	A,LPSET!LPXISX!STACKET!RETRV!CNSTR
	JRST	BFINA
↑LSTCAT:			;CONCATENATE TWO LISTS
	STAKCHECK (2,LEAVE)
	LPCALL	(CATLST)
	HRLZI	A,LPXISX!LPSET	;RESULT IS LIST
	ORM	A,@LEAPSK
	POPJ	P,
;GETTING NEW ITEMS.
DSCR NEWNOT, NEWART, GLBSET, SELET,RFIMAK
PRO NEWNOT NEWART, GLBSET, SELET
⊗
DSCR ITMTYP returns type code in A corresponding to bits in A. Normally
	A will have been loaded with TBITS entry for type 
   TYPE CODES NOW CONTAINED IN HEAD.

	STTYPE←← 3
	FLTYPE←← 4
	INTYPE←← 5	;INTEGER ITEM
	SETYPE←← 6	;SET ITEM
	LSTYPE←← SETYPE+1 ;LIST ITEM,TYPE CODE SHOULD BE 1 GTR SETYPE
	CTXTYP←← 13
	ARRTYP←← 15     ;ADDED TO MAKE ARRAY
⊗
↑ITMTYP:	PUSH	P,B		;SAVE B
		MOVEI	B,0		;INITIALLY NO TYPE
		TLNE	A,SBSCRP	;AN ARRAY?
		ADDI	B,ARRTYP
		TRNE	A,LPARRAY	;DECLARED ARRAY ITEM?
		ADDI	B,ARRTYP	;YES
		TRNN	A,SET		;A SET OR LIST?
		JRST	NTSET
		TRNE	A,FLOTNG	;A CONTEXT?
		ADDI	B,1		;MAKE UP FOR CONTEXT ≡13 BUT SET+REAL=12
		ADDI	B,SETYPE	;YES
		TRNE	A,LSTBIT	;A LIST?
		ADDI	B,1		;LIST TYPE 1 GTR THAN SET
NTSET:		TRNE	A,FLOTNG	;REAL?
		ADDI	B,FLTYPE	
		TRNE	A,STRING
		ADDI	B,STTYPE
		TRNE	A,INTEGR
		ADDI	B,INTYPE
		SKIPN	A,B
		MOVEI	A,1		;UNTYPED ITEM TYPE IS 1
		POP	P,B		;RESTORE B
		POPJ	P,

↑NEWNOT: PUSHJ	P,OKSTACK		;REGULAR NEW.
	MOVEI	A,1
	HRLM	A,BYTES		;TYPE CODE FOR UNTYPED ITEM
	LPCALL	(NEWITM)
	MOVEI	TBITS,0
	TLZ	FF,FFTEMP
	JRST	ONCON


↑NEWART: 			;NEW (ARITHMETIC ARGUMENT)
	PUSHJ	P,OKSTACK
	GETSEM	(1)
	TRNE	TBITS,ITEM!ITMVAR
	ERR	<NEW OF ITEM EXPRESSION ILLEGAL>,1
	TRNN	TBITS,SET	;IF SET, ALREADY STACKED
	JRST	NTSTKD
	TDNE TBITS,[XWD SBSCRP,FLOTNG] ;UNLESS ARRAY OR CONTEXT
	JRST 	NTSTKD
	 SOS  A,LEAPSK
	 HLRZ B,1(A); GET TYPE BITS
	 MOVEI A,SETYPE; FIRST ASSUME SET
	 TRNE B,LPXISX; A LIST
	 ADDI A,1 ; REALLY A LIST
	 JRST ISSTACK	;DON'T RESTACK IT
NTSTKD:	MOVE	A,TBITS		;PREPARE FOR CALL TO ITMTYP
	PUSHJ	P,ITMTYP	;GET TYPE	
	PUSH	P,A		;SAVE FOR LATER
	CAIN	A,CTXTYP	;CONTEXT?
	JRST	[CAME	PNT,NULLCN	;HAD BETTER BE NULL_CONTEXT
		 ERR	<ONLY NULL_CONTEXT MAY BE ARGUMENT TO NEW>,1
		 MOVEI	A,0	;WILL STACK 0
		 PUSHJ  P,CREINT
		 JRST	.+1]
	GENMOV	(STACK,GETD)	;STACK THE ARITHMETIC.
	POP 	P,A		;GET TYPE BACK
ISSTACK:
;; #MR# A STRING ARRAY IS NOT A STRING
	TLNN	TBITS,SBSCRP
	TRNN	TBITS,STRING
	JRST	NWA		;NOT A STRING
	MOVNI   B,2
	ADDM	B,SDEPTH
	CAIA
NWA:	SOS	ADEPTH		;IT IS A PARAMETER.
	HRLM	A,BYTES		;TYPE TO LEAP PARAM
	TLNE	TBITS,SBSCRP
	JRST	[LPCALL (NEWRY)
		 JRST	DCON]
	LPCALL	(NEWARITH)
DCON:
;; #NR# ↓ AVOID DRYROT REMOP STCNST
;;;	PUSHJ	P,REMOP		;STACK HAS ALREADY DONE REMOP
ONCON:	MOVSI	A,LPITM!CNSTR!STACKET	;RECORD THAT NEW ENTRY IS ITEM.
	JRST	BFINA

NOGLOC <
↑GLBST2: POPJ  P,
>;NOGLOC
GLOC <
↑GLBSET:	AOS	LEPGLB
	POPJ	P,	;$$$*** $$$*** $$$***
↑GLBST2: QPUSH	(GLBSTK,LEPGLB)	;SAVE STATE, REALLY ZERO,NON-ZERO.
	SKIPE	LEPGLB		;IF NON-ZERO
	SOS	LEPGLB		;DECREMENT
	POPJ	P,
>;GLOC


↑SELET:				;FIRST, SECOND, THIRD.

	PUSH	P,B		;SELECTOR INDEX.
GLOC <
	PUSHJ	P,GLBST2	;HANDLE "GLOBAL"
>;GLOC
	STAKCHECK (1)		;ONE ARGUMENTS.
	RETCHK			;RETRIEVAL TYPES NECESSARY
	LPCALL	(SELECT,<(P)>)
	POP	P,B
	MOVSI	A,LPITM!RETRV!STACKET	;RESULT IS AN ITEM.
	JRST	BFINA

↑RFIMAK:
	GETSEM	(1)		;THE EXPRN
	MOVEI	B,REFB		;USUALLY A REAL LIVE REF
	TLNN	TBITS,CNST	;CONSTANTS GO RIGHT AWAY
	TLNE	SBITS,ARTEMP!INUSE
	TRZ	B,REFB		;THIS IS A TEMP
	TLNE	SBITS,INDXED!PTRAC
	TRO	B,REFB		;REFERENCE !
	SKIPE	RFVALFG		;DEMANDED VALUE?
	TRZ	B,REFB
RFDAT:	MOVE	A,TBITS		;THIS IS A REFERENCE
	TRNN	TBITS,ITMVAR!ITEM ;AN ITEMVAR?
	JRST	NTITRF		;NO
ISIREF:	TRO	B,ITEMB		;YES
	TLCE	A,SBSCRP	;ARY2 THING
	TROA	B,ARY2B		;
	TLC	A,SBSCRP	;
NTITRF:	PUSHJ	P,ITMTYP	;
	LSH	A,5		;GET IT OVER
	TLNE	PNT,FBIND	;BIND?
	TRO	A,BINDB		;YES
	TLNE	PNT,QBIND	;? ?
	TRO	A,QUESB
	TRO	A,(B)		;THE ARY2 BIT & OTHERS
	GENMOV	(INCOR,0)	;BE SURE THE THING IS INCORE
	TLNE	SBITS,STTEMP	;STRING TEMP?
	JRST	ISSTTT		;YES
	HRL	PNT,A		;FOR DATUM
	SETOM	MPFLAG
	PUSHJ	P,FTRADR	;STACK THE TYPE,,POINTER
	SETZM	MPFLAG
SKKRFD:	GENMOV	(STACK,0)	;DOES THE ACTUAL STACKING
	MOVE	LPSA,GENLEF+1	;THE TEMP FROM THE EXPRN
	PUSHJ	P,REMOPL	;REMOP THE EXPRN
	MOVEI	A,RFITYP	;THE ACTUAL TYPE
	JRST	NWA		;GO PUT IT AWAY

ISSTTT:	TLZ	A,REFB		;REFB NOT
	TLO	A,SP		;IS TOP OF STRING STACK
	PUSHJ	P,CREINT	;TYPES 0(SP)
	MOVNI	A,2		;ADJUST SDEPTH
	ADDM	A,SDEPTH	;
	JRST 	SKKRFD		;GO STACK THE RFI DATUM

↑RFVAL:	SETOM	RFVALFG		;SAY IS A VALUE
	POPJ	P,

↑RFZERO: SETZM RFVALFG		;SAY IS A REF
	POPJ	P,

ZERODATA (FLAG FOR REF ITEM VALUE)
RFVALFG: 0			;FLAG USED TO SAY THIS IS A VALUE ALWAYS
ENDDATA

; CASE, EXPRESSION CONDITIONALS.

DSCR LPCS2, LPCS3, LPEXF1, LPEXF2
PRO LPCS2 LPCS3 LPEXF1 LPEXF2
⊗

↑LPCS2:	
	MOVE	SP,GENLEF+2
	PUSHJ	P,LASCHK
	SKIPN	TBITS,$TBITS(SP)
	MOVE	TBITS,A
	MOVEM	A,$TBITS(SP)
	TLNN	A,LPITM
	JRST	CASEMT		;NOT AN ITEM, SO OK.
	XOR	TBITS,A
	TDNE	TBITS,[XWD -1 ≠(CNSTR!RETRV!LPNUL),-1]
	ERR	<CASE STATEMENT MISMATCH>,1
	JRST	CASEMT


↑LPCS3:
	MOVE	SP,GENLEF+2
	MOVE	A,$TBITS(SP)
LPGO:	PUSHJ	P,BFINA
	JRST	CASEND



↑LPEXF1:
	PUSHJ	P,LASCHK
	MOVEM	A,GENRIG+1
	JRST	IFLS1

↑LPEXF2:
	PUSHJ	P,LASCHK
	PUSH	P,A
	XOR	A,GENLEF+3
	TDNE	A,[XWD -1 ≠(LPNUL!CNSTR!RETRV),-1]
	ERR	<EXPRESSION CONDITIONALS DON'T MATCH>,1
	POP	P,A			;TYPES ---
	PUSHJ	P,BFINA			;PUT BACK ON STACK.
	JRST	IFLS2
; STORE ROUTINES.

DSCR LPSTOR, LPFRSTO, LEAVE, PNAM
PRO LPSTOR LPFRSTO LEAVE PNAM
⊗

↑LPSTOR:
	TDZA	SP,SP			;NOT A FOR STATEMENT.
↑LPFRSTO: SETOM	SP
	MOVE	PNT,GENLEF+2		;SEMANTICS OF DESTINATION
	GENMOV	(ACCESS,GETD)		;GET ACCESS IF INDEXED
	JUMPL	SP,NOSQ			;IF A FOR LOOP, DO IT THE HARD WAY.
	MOVE	PNT2,@LEAPSK		;GET TOP OF STACK.
	TLNE	PNT2,LPDMY
	ERR	<THIS CONSTRUCT WON'T WORK WITHIN FOREACH>,1
	TLNN	PNT2,LPITM		;IF A SET, THEN DO IT HARD WAY.
	JRST	NOSQ			;CALL LEAP ANYWAY.
	TRNN	TBITS,ITEM!ITMVAR	;CHECK TYPE
	ERR	<STORING ITEM INTO WROND ID>,1
	TRNE	PNT2,-1			;IF A TEMP
	TLNE	PNT2,STACKE		;OR STACKED
	JRST 	ITMPOP			;WILL HAVE TO POP OFF STACK
	TLNE	TBITS,MPBIND
	JRST	ITMPOP
	MOVEM	PNT2,GENLEF+1		;EXPRESSION SEMANTICS.
	TLNN	FF,FFTEMP ;DO NOT BACK UP IF EXPRESSION STORE.
	SOS	LEAPSK
	JRST	STORG	;BACK UP IN STORE FROM WHICH WE WER CALLED.
ITMPOP:					;WILL ATTEMPT TO GENERATE POP
	PUSHJ	P,OKSTACK		;MAKE SURE TOP REALLY STACKED
	GETSEM	(2)			;GET SEMANTICS OF DEST AGAIN
	TLNE	TBITS,MPBIND		;A ? PARAMETER?
	JRST	[MOVEM	FF,FFSAVE
		 GENMOV (GET,ADDR!INDX)	;GET THE ADDRESS OF THE PARAM
		 MOVSS	D		;PREPARE FOR POP
		 EMIT <POP RP,NOUSAC!NOADDR!USX!NORLC>
		 MOVE	FF,FFSAVE
		 JRST	DECSTK		;DECREMENT STACK IF NECESSARY
		]
	EMIT	<POP RP,NOUSAC>
	TLNE	SBITS,INDXED!INUSE	;REMOP?
	PUSHJ	P,REMOP
DECSTK: SOS	B,LEAPSK
	SOS	ADEPTH
	TLNN	FF,FFTEMP		;EXPRESSION STORE?
	POPJ	P,
MODSTK:	MOVE	A,[XWD 1,1]
	PUSH	P,PNT
	PUSHJ	P,CREINT
	EMIT	<ADD RP,NOUSAC>
	POP	P,PNT
	HLL	TBITS2,1(B)		;OLD TYPE BITS
	JRST	STE
NOSQ:	TLNE	TBITS,MPBIND		;A ? PARAMETER?
	JRST	[HRRI	D,TAC1		;WANT ADDR IN TAC1
		 PUSH 	P,TBITS
		 GENMOV (GET,ADDR!SPAC)
		 JRST	NOSQ2]
	MOVE	A,[HRROI TAC1,NOUSAC]
	TRNE	TBITS,ITEM!ITMVAR
	HRLI	A,(<MOVEI TAC1,0>)
	PUSHJ	P,EMITER
	PUSH	P,TBITS			;PRESERVE DESTINATION TYPE.
NOSQ2:	JUMPN	SP,.+3			;ONLY IF NOT OUR MAN FOR.
	TLNE	SBITS,INDXED!INUSE
	PUSHJ	P,REMOP		;REMOP HERE SINCE LPCALL CALLS
					;ALLSTO.
	STAKCHECK	(1)		;AFTER THE MOVEI BECAUSE THIS WILL
					;CHANGE ADEPTH, ETC....
	POP	P,TBITS
	XPREP
	TLNE	A,LPITM
	JRST	[TRNN	TBITS,ITMVAR
		ERR	<STORING ITEM INTO WROND ID>,1
		 JRST	TYPOK]
	TLNN	A,LPSET!LPXISX
        ERR 	<NEITHER SET, LIST, NOR ITEM EXPRESSION>,1,TYPOK
;; #HW# BY JRL 6-22-72 A SET ITEMVAR IS NOT A SET (LHS ASSIGNMENT)
	TRNE	TBITS,ITEM!ITMVAR	;BETTER NOT BE ITEM
	ERR	<STORING LIST OR SET INTO ITEM OR ITEMVAR>,1
;; #HW#
	TRNN	TBITS,SET
	ERR	<STORING LIST INTO WRONG ID>,1
	TLNE	A,LPXISX		;A LIST TO BE STORED?
	TRNE	TBITS,LSTBIT		;A LIST DESTINATION
	CAIA
	ERR	<STORING LIST EXPRESSION INTO SET>,1

TYPOK:  JUMPN	SP,STD			;IF WITHIN FOR CAN'T BE EXPRESSION
	MOVE	TBITS2,A
	TLNN	FF,FFTEMP		;EXPRESSION STORE??
	JRST	STD			;NO
	LPCALL	(STORBUTDONTREMOVE)
	JRST	STE
STD:	LPCALL	(STORE)
STE:	JUMPN	SP,LFOR
	TLNN	FF,FFTEMP
	POPJ	P,
	TLNN	SBITS,INDXED!FIXARR
	JRST	STE1
	GETBLK	(PNT)			;GET A DUMMY SEMBLK.
	TLO	TBITS2,DUMSEM		;MARK THIS AS A DUMMY
	MOVEM	TBITS,$TBITS(PNT)
STE1:	HRRI	A,(PNT)
	MOVEM	PNT,GENRIG+1	;SAVE FOR OTHERS.
	HLL	A,TBITS2
	JRST	BFINA		;MARK THE LEAP STACK.


↑LEAVE:				;ENTERED FROM ECHK, OTHERS?
	MOVE	A,@LEAPSK	;IS IT STACKED??
	TRNE	A,-1		;SEE IF HAS SEMBLK POINTER
	TLNE	A,STACKET	;
	JRST	NOWW		;NO CLEVER.
	TLNE	A,LPDMY		;A CRAZY DERIVED SET OR BTRIP
	JRST	[ERR <DERIVED SET OR BRACKETED TRIPLE DOESN'T WORK HERE>,1
		      MOVE A,GENLEF+1 ;MAYBE THIS WILL SAVE REST OF COMPILING
		JRST .+1]
	MOVE	TBITS,$TBITS(A)
	TRNN	TBITS,ITEM!ITMVAR!SET!LSTBIT
	JRST	NOWW
	HRRZM	A,GENLEF+1
	TLNE	A,FBIND!QBIND
	HLLM	A,GENLEF+1	;LEAVE FBIND,QBIND BITS FOR CALARG TO FIND
	SOS LEAPSK
	POPJ	P,
NOWW:	
	TLNE	A,LPITM
	JRST	[PUSHJ P,GETAC  ;AN AC TO STORE IT IN
		 HRLI C,(D)	;THE AC NUMBER
		 EMIT <POP RP,NOUSAC!USADDR!NORLC>
		 SOS LEAPSK
		 SOS ADEPTH
;; #KJ BY JRL (11-21-72) FOLLOWING INSTR WAS HRRI, GOT GARBAGE LH BITS
		 MOVEI TBITS,ITMVAR
		 SETZM SBITS
		 PUSH P,TBITS
		 JRST MARW]
	STAKCHECK (1)		;MAKE SURE THIS IS THE VERY TOP.
	SETZB	SBITS,TBITS
	TLNE	A,LPSET
	TRO	TBITS,SET
	TLNE	A,LPXISX
	TRO	TBITS,LSTBIT
	PUSH	P,TBITS
	XPREP
	HRLI	C,1		;POP INTO AC 1
	EMIT    <POP RP,NORLC!USADDR!NOUSAC>
MARW:	GENMOV	(MARK,0)
	MOVEM	PNT,GENLEF+1
	POP	P,$TBITS(PNT)	;SINCE MARK IS INCREDIBLY STUPID.
	POPJ	P,


↑MAKEST:			;PERFORM CONVERSION TO SET FOR INSIST(GENMOVE)
	GENMOV  (STACK,GETD)	;STACK LIST
	LPCALL	(SETLST)	;CONVERT TO SETLST
POPMRK:	XPREP
	SOS	ADEPTH		;REMOVEING FROM STACK
	HRLI	C,1
	EMIT	<POP RP,USADDR!NORLC!NOUSAC>
	GENMOV	(MARK,0)	;MARK RESULT
	MOVEI	A,SET
	MOVEM	A,$TBITS(PNT)
	POPJ	P,

↑MAKLST:			;PERFORM CONVERSION TO LIST FOR INSIST(GENMOV)
	POPJ	P,		;NO DUPLICATION NOW.

↑PNAM:	
	SKIPE	PNMSW
	ERR	<SAY PNAMES ONLY ONCE>,1
	AOS	PNMSW		;WILL COUNT PNAMES.
	MOVE	A,SCNVAL	;FROM REQUIRE
	MOVEM	A,PNAMNO	;FOR ALLOCATION STUFF.
	QPUSH	(PNLST)
	QPOP	(PNLST)
	MOVE	A,PNLST
	MOVEM	A,PNBEG		;SAVE FOR TAKING THINGS OUT.
	POPJ	P,



↑ALLGLB: SETOM	ALLGLO		;EVERY OPERATION IS TO BE CONSIDERED GLOBAL
	POPJ	P,

DSCR CALMP -MATCHING PROCEDURE EXECS
⊗
↑↑CALMP:
	MOVE PNT2,GENLEF+1		;PROCEDURE SEMANTICS
	HRRZ	PNT,$VAL(PNT2)		;
	HRRI	D,TEMP			;WE WANT IT LOADED INTO TEMP
	PUSHJ	P,LODPDA		;ADDR OF PDA ONTO STACK
	HRLI	C,TEMP			;PREPARE FOR PUSH
	EMIT	<PUSH RP,NOUSAC!NORLC!USADDR> ;PUSH PDA ONTO STACK
	LPCALL	(MATCAL)		;CALL MATCHING PROCEDURE
	SOS	ADEPTH			;FOR ITEM PARAM TO SPROUT
	SETZM	NEDPOP			;THE MP HAS DONE THE POP FOR US
; ADEPTH,SDEPTH HAVE ALREADY BEEN DECREMENTED BY ISUCAL FOR PARAMS
LPMPAR:	QPOP	(MPQSTK)		;POP OFF
	JUMPE	A,NOMORE		;ALL DONE?
	HRLZI	SBITS,LPFREE
	ANDCAM	SBITS,$SBITS(A)		;THE ? PARMS ARE NO LONGER FREEE
	JRST	LPMPAR
NOMORE:	QPUSH	(MPQSTK,A)		;PUT MARKER BACK ON
	POPJ	P,

↑↑SUCCEX:
	PUSHJ	P,ALLSTO		;NOTHING IS SAVED OVER CALL
	QPOP	(MPSTAK)
	JUMPE	A,SUCCER
SUCCON:	QPUSH	(MPSTAK,A)		;PUT IT BACK ON
	PUSH	P,A
	PUSH	P,B			;SAVE INDEX
	HRRZ	PNT,$VAL(A)		;PDA SEMBLK
	MOVS	C,$ADR(PNT)		;
	MOVE	A,[HRRZI TEMP,NOUSAC!JSFIX]
	TRNE	C,-1			;ALREADY PUT OUT
	HRRI	A,NOUSAC!USADDR		;NO.
	PUSHJ	P,EMITER
	QLOOK	(MPVSTK)		;XWD ?TABLE,,LEVEL
	MOVE	C,(A)
	EMIT	<HRLI	TEMP,NOUSAC!USADDR>
	HRLI	C,TEMP
	EMIT	<PUSH RP,NOUSAC!USADDR!NORLC>
	MOVE	A,(P)			;SUCC OR FAIL
	ADDI	A,R.SUCCE+LIBTAB	;LIBTAB INDEX
	PUSHJ	P,XCALLQ		;CALL SUCCEED OR FAIL
;; THE SKIP RETURN FROM .SUCC SHOULD BE INVERTED IN THE RUNTIMES
;; UNTIL THAT TIME WE WILL DO IT HERE
	EMIT	<SKIPA ,NOUSAC!NOADDR>
;; END OF TEMPORARY HACK
	HRL	C,PCNT
	ADD	C,[XWD 6,0]
	EMIT	<JRST , NOUSAC!USADDR>
	MOVE	PNT,-1(P)			;THE PROC SEMBLK
	HRR	PNT,$VAL(PNT)		;THE PDA SEMBLK
	MOVS	C,$ADR(PNT)		;
	MOVE	A,[HRRZI LPSA,NOUSAC!JSFIX]
	TRNE	C,-1			;ALREADY PUT OUT
	HRRI	A,NOUSAC!USADDR		;NO.
	PUSHJ	P,EMITER
	QLOOK	(MPQSTK)
	HRLZ	C,(A)			;THE LEXICAL LEVEL
	EMIT	<HRLI LPSA,USADDR!NORLC!NOUSAC>
	XCALL	<STKUWD>
	POP	P,C			;SUCCEED OR FAIL
	MOVE	A,[SETZ A,NOUSAC!NOADDR] ;ASSUME FALSE
	SKIPN	C
	HRLI	A,(<SETO A,>)
	PUSHJ	P,EMITER		;THE TRUTH VALUE TO BE RETURNED
	POP	P,PNT			;PROC SEMBLK
	HRLZ	C,$ACNO(PNT)		;FIXUP FOR EXIT
	HRRZ	D,PCNT			;CURRENT PC
	HRRM	D,$ACNO(PNT)
	EMIT	<JRST NOUSAC!USADDR>
	POPJ	P,
SUCCER:	ERR <SUCCEED OR FAIL MUST BE WITHIN MATCH. PROC>,1
	JRST    SUCCON
↑SAMEV:
	MOVE	PNT,GENLEF+4		;FIRST ITEMVAR
	MOVE	PNT2,GENLEF+2
	MOVE	TBITS,$TBITS(PNT)	;SEE IF REALLY A MP PARM.
	TLNN	TBITS,MPBIND
	JRST	FALCON			;NO ALWAYS FALSE.
	MOVE	TBITS,$TBITS(PNT2)
	TLNN	TBITS,MPBIND
	JRST	FALCON	
	PUSHJ	P,GETAC			;GET AN AC TO PLAY WITH
	EMIT	<MOVE ,>		;LOAD WITH FIRST ITEMVAR
	MOVE	PNT,PNT2		;SECOND ITEMVAR SEMBLK
	EMIT	<CAMN ,>		;COMPARE FIRST WITH SECOND
	HRLI	C,20			;INDIRECT BIT FOR NEXT INSTR
	EMIT	<TLNN ,NORLC!USADDR>
	HRLI	C,(D)			;THE AC ITEMVAR IN.
	EMIT	<TDZA ,NORLC!USADDR> ;FALSE
	HRLI	C,1
	EMIT	<MOVNI ,NORLC!USADDR>;TRUE
	PUSHJ	P,MARKINT
	MOVEM	PNT,GENRIG+1
	POPJ	P,
FALCON: MOVNI	A,1
	PUSHJ	P,CREINT
	MOVEM	PNT,GENRIG+1
	POPJ	P,


DSCR REMEMBER EXECS RMASET,RMBSET,RMSTK
⊗
;TYPE BITS TO BE PASSED TO RUNTIMES
DESC ←← 400000
ISARR ←← 200000
ISSTR ←← 100000
ISSET ←← 40000

↑RMASET:					;REMEMBER ALL
	HRLZM	B,REMCEL		;SAVE WHICH KIND OF OPERATION,# PARAMS
	POPJ	P,

↑RMBSET:					;REM,FOR,RES NAMED ENTRIES
	ADDI	B,3
	HRLI	B,1
	MOVSM	B,REMCEL		;SAVE WHICH KIND
	MOVEI	A,0			;CREATE ZERO CONSTANT
	PUSHJ	P,CREINT
	GENMOV	(STACK,GETD)
	POPJ	P,
↑RMSTK:
	AOS 	REMCEL
	GETSEM	(1)			;SEMANTICS OF VARIABLE TO BE SAVED ETC
	TRNE	TBITS,ITEM		;DON'T ALLOW ITEM TO BE SAVED ETC
	ERR	<AN ITEM IS NOT A VARIABLE CAN'T BE REMEMBERED>,1
	TLNN	TBITS,SBSCRP		;ARRAYS ARE NEVER ON LEAPSK
	TRNN	TBITS,SET!ITMVAR	;LEAPISH THING?
	JRST    HVPNT			;NO.
	SOS	B,LEAPSK		;GET SEMAN FROM LEAP STACK
	MOVE	PNT,1(B)		;SEMBLK
	TLNE	PNT,STACKET		;ALREADY STACKED?
	ERR	<EXPRESSIONS CANNOT BE REMEMBERED>,1
HVPNT:
	HRRZS	PNT			;PREPARE TO CALCULATE TYPE BITS
	TLNE	TBITS,SBSCRP		;AN ARRAY?
	TLO	PNT,ISARR		;TELL THE WORLD
	TRNE	TBITS,STRING
	TLO	PNT,ISSTR
	TRNN	TBITS,SET
	JRST	RMEXPR
	TRNE	TBITS,FLOTNG!INTEGR
	ERR	<KILL_SETS AND CONTEXTS MAY NOT BE REMEMBERED>,1
	TLO	PNT,ISSET
RMEXPR:	TLNE	SBITS,ARTEMP!STTEMP	;AN EXPRESSION?
	TLNE	TBITS,SBSCRP		;OK IF ARRAY
	JRST	RMSTK2			;NO
	TLNN	SBITS,FIXARR!INDXED	;
	ERR	<EXPRESSION CANNOT BE REMEMBERED>,1
RMSTK2:
	TLNN	SBITS,FIXARR!INDXED	;IF NOT ARRAY ELEM
	PUSHJ   P,INCOR			;MAKE SURE INCORE
	SETOM	MPFLAG			;WANT BITS IN LEFT HALF
	PUSHJ	P,FTRADR		;MAKE LIKE A FORTRAN CALL
	GENMOV	(STACK,GETD)
	SETZM	MPFLAG
	POPJ	P,

↑CNTXTS: 				;STACK CONTEXT VARIABLE AND CALL ROUTINE
	GETSEM	(1)
	PUSHJ	P,ADRINS		;GET ADDRESS OF CONTEXT VARIABLE
	GENMOV	(STACK,0)		;STACK IT
	PUSHJ	P,ALLSTO		;MAKE SURE NOTHING IN AC
	HRLI	A,LIBTAB+RALLRM 	;
	ADD	A,REMCEL
	HLRZ	A,A
	PUSHJ	P,XCALLQ
	HRRZ	A,REMCEL
	ADDI	A,1
	MOVNS	A
	ADDM	A,ADEPTH
	POPJ	P,

↑INCNTX: GETSEM (1)
	GENMOV (STACK,0)		;STACK VAL
	XPREP
	XCALL	(.INCON)
	PUSHJ	P,MARKINT
	MOVEM	PNT,GENRIG
	POPJ	P,
↑NLCNXT:				;NULL_CONTEXT
	MOVE	PNT,NULLCN		;DUMMY SEMBLK FOR NULL_CONTEXT
	MOVEM	PNT,GENRIG		;STORE IT AWAY
	POPJ	P,
↑CONELM:				;CNTX:VAR CONSTRUCT
	GETSEM	(3)			;THE CONTEXT
	GENMOV	(STACK,0)		;STACK IT
	GETSEM	(1)			;THE VARIABLE NAME
	PUSH	P,TBITS			;SINCE HVPNT WILL DESTROY
	PUSHJ	P,HVPNT			;STACK IT
	POP	P,TBITS			;HVPNT DESTROYED
	XPREP				;CONELM WILL RETURN RESULT IN 1
	XCALL	(CONELM)
	MOVNI	TEMP,2			;UPDATE P-STACK
	ADDM	TEMP,ADEPTH
	PUSHJ	P,TYPDEC		;TYPE THE THING
	MOVEM	A,PARRIG+1
	TLZ	TBITS,OWN!FORMAL!MPBIND ;IF ARRAY NO LONGER OWN
	PUSH	P,PNT
	PUSH	P,TBITS			;SAVE OVER CALL TO MARK
	SETZB	TBITS,SBITS
	GENMOV	(MARK,0)		;GET A TEMP
	MOVEM	PNT,GENRIG+1
	HRROS	$ACNO(PNT)		;FOR ARRAYS
	POP	P,TBITS
	POP	P,TEMP
	TLNE	TBITS,SBSCRP		;AN ARRAY?
	MOVEM	TEMP,$VAL(PNT)		;NAME FOR ARRERR UUO
	MOVEM	TBITS,$TBITS(PNT)	;STORE REAL TBITS
	TLC	SBITS,INAC!PTRAC!INDXED
	MOVEM	SBITS,$SBITS(PNT)	;STORE REAL SBITS
	POPJ	P,
BEND LEAP


COMMENT ⊗ EXECS FOR DYNAMIC BINDING OF PROC ITEMS⊗

DSCR PDASTK
DES EMITS CODE TO PUSH ONTO THE P-STACK PDA OF NAMED PROC

⊗

↑PDASTK:	
	MOVE	PNT2,GENLEF+1		;GET SEMBLK FOR PROC ID
	HRRZ	PNT,$VAL(PNT2)		;POINT AT PD SEMBLK
	PUSHJ	P,GETAC			;GETS AN AC
	PUSHJ	P,LODPDA
	HRL	C,D
	EMIT	<PUSH P,NOUSAC!USADDR!NORLC> ;PUSH P,AC
	AOS	ADEPTH			;HIT THEE BOOKS
	POPJ	P,

↑LODPDA:				;LOADS PDA NAMED BY PNT INTO AN AC NAMED
					;IN RH OF D (MANGLES C)
					;ASSUMES PROC SEMBLK IS IN PNT2
	SKIPL	C,$ADR(PNT)		;IS THE ADDRESS TRUE YET ?
	JRST	EMJSF			;NO, DO A FIXUP
	HRLZ	C,C			;PICK UP THE ADDRESS OF THE PDA
	EMIT	<MOVEI  USADDR>		;GO PUT IT OUT
	POPJ	P,			;RETURN
EMJSF:	MOVE	A,[MOVEI JSFIX]		;MOVEI A,PDA
	MOVE	C,$TBITS(PNT2)		;
	TLNE	C,EXTRNL
	MOVE	A,[MOVE JSFIX]
	PUSHJ	P,EMITER
	POPJ	P,

DSCR COPPIT
DES EMITS CODE TO CALL PITCOP TO COPY ONE FHQ PROC ITEM DATUM INTO ANOTHER ITEM
	DATUM. DOES A STORZ ON B&C TO FREE THEM UP -- WARNING: THIS MAY
	CONFLICT WITH THE PROTECT_ACS FEATURE.  

⊗

↑COPPIT:
	MOVEI	D,B
	PUSHJ	P,STORZ			;FREE UP B
	MOVEI 	D,C			
	PUSHJ	P,STORZ			;FREE UP C
	XCALL	(PITCOP)
;;#LH# 1 OF 2 RHT 2-6-73 ADJUST ADEPTH
	MOVNI	D,2
	ADDM	D,ADEPTH
;;#LH#
	POPJ	P,

DSCR BINCL
DES EMITS CODE TO CALL PITBND -- ALSO FREES UP B&C

⊗

↑BINCL:

	MOVEI	D,B
	PUSHJ	P,STORZ			;FREE UP B
	MOVEI 	D,C			
	PUSHJ	P,STORZ			;FREE UP C
	XCALL	(PITBND)
;;#LH# 2 OF 2 RHT 2-6-73 ADJUST ADEPTH
	MOVNI	D,2
	ADDM	D,ADEPTH
;;#LH#
	POPJ	P,

COMMENT ⊗EXECS FOR APPLY⊗

DSCR EVLLST,EVLNLL,PITSTK
DES USED TO SET UP INTERP CALL
⊗

↑EVLLST:
	PUSHJ	P,BNDLST		;GET LIST STACKED
	JRST	XCLEVL			;GO CALL THE CALLER
↑EVLNLL:
	MOVEI	A,0
	PUSHJ	P,CREINT		;GET A ZERO
	GENMOVE	(STACK)			;STACK IT
XCLEVL:	XCALL	(APPLY)			;CALL APPLY
;;#JS#  ADJUST ADEPTH RHT 10-20-72
	MOVNI	A,2			;
	ADDM	A,ADEPTH		;
;;#JS#
	POPJ	P,


↑PITSTK:
	MOVEI	D,B		;FREE UP B & C
	PUSHJ	P,STORZ
	MOVEI	D,C
	PUSHJ	P,STORZ
	XCALL	(PITDTM)	;
	POPJ	P,




;; EXECS FOR SPROUT APPLY

↑SAPPL1:MOVEI	PNT,-1
	MOVE	PNT2,GENLEF+2
	HRRM	PNT,$VAL2(PNT2)	;MARK SPROUT SEMBLK AS SPROUT APPLY
	POPJ	P,

↑SAPPL:	PUSHJ	P,BNDLST	;GET ARG LIST ON STACK
	JRST	SAPPP
↑SAPPN:	MOVEI	A,0
	PUSHJ	P,CREINT	;A NULL
	GENMOVE (STACK,0)	;STACK IT
SAPPP:	
	HRL	C,PCNT
	EXCH	C,RAPPL$Y	;FIXUP ON APPL$Y
	EMIT	<MOVEI	TEMP,NOUSAC!USADDR>
	HRLI	C,TEMP
	EMIT	<PUSH RP,NOUSAC!USADDR!NORLC>
	AOS	ADEPTH
	POPJ	P,